;;; org-ql-view.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*- ;; Author: Adam Porter ;; Url: https://github.com/alphapapa/org-ql ;; Package-Requires: ((transient) (map "2.0")) ;;; Commentary: ;; This library is part of the package `org-ql'; it's not a standalone ;; library. It displays strings in buffers similar to Org Agenda ;; buffers. ;;; License: ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Code: ;;;; Requirements (require 'cl-lib) (require 'crm) (require 'map) (require 'org) (require 'org-element) (require 'org-agenda) (require 'seq) (require 'rx) (require 'subr-x) (require 'org-ql) (require 'dash) (require 's) (require 'org-super-agenda) (require 'ov) (require 'ts) ;;;; Compatibility (when (version< org-version "9.2") (defalias 'org-get-tags #'org-get-tags-at)) ;;;; Faces (defface org-ql-view-due-date '((t (:slant italic :weight bold))) "Face for due dates in `org-ql-view' views." :group 'org-ql) ;;;; Variables (defvar org-ql-view-buffer-name-prefix "*Org QL View:" "Prefix for names of `org-ql-view' buffers.") (defvar org-ql-view-buffer nil "Optionally set the target buffer for `org-ql-view' commands. Includes `org-ql-search'. Helpful when passing a buffer argument down a chain of function calls would be awkward.") (defvar org-ql-view-map (let ((map (make-sparse-keymap))) (set-keymap-parent map org-agenda-mode-map) (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) map) "Keymap for `org-ql-view', `org-ql-search', and `org-ql-views' views. Based on `org-agenda-mode-map'.") (defvar org-ql-view-list-map (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") #'org-ql-view-switch) (define-key map [mouse-1] #'org-ql-view-switch) (define-key map "c" #'org-ql-view-customize) map) "Keymap for `org-ql-view' view list buffer.") ;; For refreshing results buffers. (defvar-local org-ql-view-buffers-files nil) (defvar-local org-ql-view-query nil) (defvar-local org-ql-view-sort nil) (defvar-local org-ql-view-narrow nil) (defvar-local org-ql-view-super-groups nil) (defvar-local org-ql-view-title nil) ;;;; Customization (defgroup org-ql-view nil "Options for `org-ql-view'." :group 'org-ql) (defcustom org-ql-view-display-buffer-action nil "Action argument passed through `pop-to-buffer' to `display-buffer', which see." :type '(cons function alist)) (defcustom org-ql-view-list-side 'right "Which side to show the view list on." :type '(choice (const :tag "Left" left) (const :tag "Right" right))) (defcustom org-ql-view-no-other-window nil "Whether `other-window' commands should cycle through `org-ql-views' sidebar. See info node `(elisp)Cyclic Window Ordering'." :type 'boolean) (defcustom org-ql-view-list-slot 0 "Side-window slot for Org QL Views list buffer." :type 'integer) (defcustom org-ql-view-sidebar-sort-views nil "Sort `org-ql-views' in `org-ql-view-sidebar'." :type 'boolean) (defcustom org-ql-views (list (cons "Overview: Agenda-like" (list :buffers-files #'org-agenda-files :query '(and (not (done)) (or (habit) (deadline auto) (scheduled :to today) (ts-active :on today))) :sort '(date priority todo) :super-groups 'org-super-agenda-groups :title "Agenda-like")) (cons "Overview: NEXT tasks" (list :buffers-files #'org-agenda-files :query '(todo "NEXT") :sort '(priority date) :super-groups 'org-super-agenda-groups :title "Overview: NEXT tasks")) (cons "Calendar: Today" (list :buffers-files #'org-agenda-files :query '(ts-active :on today) :title "Today" :super-groups 'org-super-agenda-groups :sort '(priority))) (cons "Calendar: This week" (lambda () "Show items with an active timestamp during this calendar week." (interactive) (let* ((ts (ts-now)) (beg-of-week (->> ts (ts-adjust 'day (- (ts-dow (ts-now)))) (ts-apply :hour 0 :minute 0 :second 0))) (end-of-week (->> ts (ts-adjust 'day (- 6 (ts-dow (ts-now)))) (ts-apply :hour 23 :minute 59 :second 59)))) (org-ql-search (org-agenda-files) `(ts-active :from ,beg-of-week :to ,end-of-week) :title "This week" :super-groups 'org-super-agenda-groups :sort '(priority))))) (cons "Calendar: Next week" (lambda () "Show items with an active timestamp during the next calendar week." (interactive) (let* ((ts (ts-adjust 'day 7 (ts-now))) (beg-of-week (->> ts (ts-adjust 'day (- (ts-dow (ts-now)))) (ts-apply :hour 0 :minute 0 :second 0))) (end-of-week (->> ts (ts-adjust 'day (- 6 (ts-dow (ts-now)))) (ts-apply :hour 23 :minute 59 :second 59)))) (org-ql-search (org-agenda-files) `(ts-active :from ,beg-of-week :to ,end-of-week) :title "Next week" :super-groups 'org-super-agenda-groups :sort '(priority))))) (cons "Review: Recently timestamped" #'org-ql-view-recent-items) (cons (propertize "Review: Dangling tasks" 'help-echo "Tasks whose ancestor is done") (list :buffers-files #'org-agenda-files :query '(and (todo) (ancestors (done))) :title (propertize "Review: Dangling tasks" 'help-echo "Tasks whose ancestor is done") :sort '(date priority todo) :super-groups '((:auto-parent t)))) (cons (propertize "Review: Stale tasks" 'help-echo "Tasks without a timestamp in the past 2 weeks") (list :buffers-files #'org-agenda-files :query '(and (todo) (not (ts :from -14))) :title (propertize "Review: Stale tasks" 'help-echo "Tasks without a timestamp in the past 2 weeks") :sort '(date priority todo) :super-groups '((:auto-parent t)))) (cons (propertize "Review: Stuck projects" 'help-echo "Tasks with sub-tasks but no NEXT sub-tasks") (list :buffers-files #'org-agenda-files :query '(and (todo) (descendants (todo)) (not (descendants (todo "NEXT")))) :title (propertize "Review: Stuck projects" 'help-echo "Tasks with sub-tasks but no NEXT sub-tasks") :sort '(priority date) :super-groups 'org-super-agenda-groups))) "Alist of `org-ql-view' commands." :type '(alist :key-type (string :tag "Name") :value-type (choice (function :tag "Function which calls `org-ql-search'") (plist :tag "Org QL Search" :options (((const :tag "Buffers/files" :buffers-files) (choice (function-item :tag "Org Agenda Files" org-agenda-files) (repeat :tag "Buffer or file names" string) (function :tag "Function which returns a list of buffers and/or files" list))) ((const :tag "Query" :query) (sexp :tag "org-ql query sexp")) ((const :tag "Search title" :title) string) ((const :tag "Sort-by" :sort) (repeat (choice (const date) (const deadline) (const scheduled) (const todo) (const priority) (const random) (function :tag "Custom comparator")))) ((const :tag "Group-by" :super-groups) (choice (variable-item :tag "Default org-super-agenda groups" org-super-agenda-groups) (sexp :tag "org-super-agenda grouping expression") (variable :tag "Variable holding org-super-agenda grouping expression")))))))) ;;;; Commands ;;;###autoload (defun org-ql-view (&optional name) "Choose and display the `org-ql-views' view NAME. Interactively, prompt for NAME." (interactive (list (completing-read "View: " (mapcar #'car org-ql-views)))) (let* ((view (alist-get name org-ql-views nil nil #'string=)) (window (--find (string-prefix-p org-ql-view-buffer-name-prefix (buffer-name (window-buffer it))) (window-list))) (org-ql-view-display-buffer-action (when (and window (not org-ql-view-display-buffer-action)) (cons #'display-buffer-same-window nil)))) (when window (select-window window)) (cl-typecase view (function (call-interactively view)) (list (-let* (((&plist :buffers-files :query :sort :narrow :super-groups :title) view) (super-groups (cl-typecase super-groups (symbol (symbol-value super-groups)) (list super-groups)))) (org-ql-search buffers-files query :super-groups super-groups :narrow narrow :sort sort :title title :buffer org-ql-view-buffer)))))) ;;;###autoload (cl-defun org-ql-view-recent-items (&key num-days (type 'ts) (files (org-agenda-files)) (groups '((:auto-parent t) (:auto-todo t)))) "Show items in FILES from last NUM-DAYS days with timestamps of TYPE. TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or `closed'." (interactive (list :num-days (read-number "Days: ") :type (->> '(ts ts-active ts-inactive clocked closed) (completing-read "Timestamp type: ") intern))) ;; It doesn't make much sense to use other date-based selectors to ;; look into the past, so to prevent confusion, we won't allow them. (-let* ((query (pcase-exhaustive type ((or 'ts 'ts-active 'ts-inactive) `(,type :from ,(- num-days) :to 0)) ((or 'clocked 'closed) `(,type :from ,(- num-days) :to 0))))) (org-ql-search files query :title "Recent items" :sort '(date priority todo) :super-groups groups))) ;;;###autoload (cl-defun org-ql-view-sidebar (&key (slot org-ql-view-list-slot)) "Show `org-ql-view' view list sidebar." ;; TODO: Update sidebar when `org-ql-views' changes. (interactive) (select-window (or (get-buffer-window (org-ql-view--list-buffer)) (display-buffer-in-side-window (org-ql-view--list-buffer) (list (cons 'side org-ql-view-list-side) (cons 'slot slot) (cons 'window-parameters (list (cons 'no-delete-other-windows t) (cons 'no-other-window org-ql-view-no-other-window)))))))) (defun org-ql-view-switch () "Switch to view at point." (interactive) (let ((key (buffer-substring-no-properties (point-at-bol) (point-at-eol)))) (unless (string-empty-p key) (ov-clear :org-ql-view-selected) (ov (point-at-bol) (1+ (point-at-eol)) :org-ql-view-selected t 'face '(:weight bold :inherit highlight)) (org-ql-view key)))) (defun org-ql-view-refresh (&optional prompt) "Refresh current `org-ql-search' buffer. If PROMPT is non-nil (interactively, with prefix), prompt to update search arguments." (interactive "P") (unless org-ql-view-buffers-files (user-error "Not an Org QL View buffer")) (let* ((current-line (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (old-pos (point)) (defaults (list org-ql-view-buffers-files org-ql-view-query :sort org-ql-view-sort :narrow org-ql-view-narrow :super-groups org-ql-view-super-groups :title org-ql-view-title)) (org-ql-view-buffer (current-buffer))) (if prompt (call-interactively #'org-ql-search) (apply #'org-ql-search defaults)) ;; Now in the results buffer. (rename-buffer (format "%s %s*" org-ql-view-buffer-name-prefix (or org-ql-view-title org-ql-view-query))) (goto-char (point-min)) (or (when (search-forward current-line nil t) (beginning-of-line)) (goto-char old-pos)) (message "View refreshed"))) (defun org-ql-view-save () "Save current `org-ql-search' buffer to `org-ql-views'." (interactive) (let* ((name (read-string "Save view as: " org-ql-view-title)) (plist (list :buffers-files org-ql-view-buffers-files :query org-ql-view-query :sort org-ql-view-sort :narrow org-ql-view-narrow :super-groups org-ql-view-super-groups :title name))) (when (or (not (map-elt org-ql-views name nil)) (yes-or-no-p (format "Overwrite view \"%s\"?" name))) (setf (map-elt org-ql-views name nil #'equal) plist) (customize-set-variable 'org-ql-views org-ql-views) (customize-mark-to-save 'org-ql-views)))) (defun org-ql-view-delete () "Delete current view (with confirmation)." (interactive) (when (yes-or-no-p (format "Delete view \"%s\"?" org-ql-view-title)) (setf org-ql-views (--remove (equal (car it) org-ql-view-title) org-ql-views)) (customize-set-variable 'org-ql-views org-ql-views) (customize-mark-to-save 'org-ql-views))) (defun org-ql-view-customize () "Customize view at point in `org-ql-view-sidebar' buffer." (interactive) (let ((key (buffer-substring-no-properties (point-at-bol) (point-at-eol)))) (customize-option 'org-ql-views) (search-forward (concat "Name: " key)))) ;;;; Functions (defun org-ql-view--list-buffer () "Return view list buffer." (with-current-buffer (get-buffer-create "*Org QL View List*") (use-local-map org-ql-view-list-map) (setf buffer-read-only t mode-line-format nil header-line-format (propertize " Org QL Views" 'face 'header-line)) (let ((inhibit-read-only t)) (erase-buffer) (->> org-ql-views (-map #'car) (-sort (if org-ql-view-sidebar-sort-views #'string< #'ignore)) (s-join "\n") insert)) (current-buffer))) (cl-defun org-ql-view--display (&key (buffer org-ql-view-buffer) header string) "Display STRING in `org-ql-view' BUFFER. BUFFER may be a buffer, or a string naming a buffer, which is reused if it already exists. `org-ql-view-buffer' is used by default. HEADER is a string displayed in the buffer's header line. The following special variables, if non-nil, are set buffer-locally to preserve their value in the buffer for subsequent refreshing of the buffer: `org-ql-view-buffers-files', `org-ql-view-query', `org-ql-view-sort', `org-ql-view-narrow', `org-ql-view-super-groups', `org-ql-title.'" (declare (indent defun)) (let* ((vars (list 'org-ql-view-buffers-files 'org-ql-view-query 'org-ql-view-sort 'org-ql-view-narrow 'org-ql-view-super-groups 'org-ql-view-title)) ;; Save the values of variables which are set buffer-locally in the ;; results buffer, which we want to override and set buffer-locally again. (vals (cl-loop for symbol in vars collect (cons symbol (symbol-value symbol)))) (buffer (cl-etypecase buffer (string (org-ql-view--buffer buffer)) (null (org-ql-view--buffer buffer)) (buffer buffer)))) (with-current-buffer buffer (use-local-map org-ql-view-map) ;; Prepare buffer, saving data for refreshing. (cl-loop for symbol in vars do (progn (kill-local-variable symbol) (set (make-local-variable symbol) (alist-get symbol vals nil nil #'equal)))) (setf header-line-format header) ;; Clear buffer, insert entries, etc. (let ((inhibit-read-only t)) (erase-buffer) (insert string "\n") (pop-to-buffer (current-buffer) org-ql-view-display-buffer-action) (org-agenda-finalize) (goto-char (point-min)))))) (cl-defun org-ql-view--header-line-format (&key buffers-files query title) "Return `header-line-format' for BUFFERS-FILES and QUERY. If TITLE, prepend it to the header." (let* ((title (if title (concat (propertize "View:" 'face 'transient-argument) title " ") "")) (query-formatted (when query (org-ql-view--format-query query))) (query-width (when query-formatted (length query-formatted))) (query-propertized (when query-formatted (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted) 'help-echo query-formatted))) (available-width (max 0 (- (window-width) (length "In: ") (length "Query: ") (or query-width 0) 4))) (buffers-files-formatted (when buffers-files (format "%s" (org-ql-view--contract-buffers-files buffers-files)))) (buffers-files-formatted (when buffers-files-formatted (propertize (->> buffers-files-formatted (org-ql-view--font-lock-string 'emacs-lisp-mode) (s-truncate available-width)) 'help-echo buffers-files-formatted)))) (concat title (when query (propertize "Query:" 'face 'transient-argument)) (when query query-propertized) (when query " ") (when buffers-files (propertize "In:" 'face 'transient-argument)) (when buffers-files-formatted buffers-files-formatted)))) (defun org-ql-view--format-query (query) "Return QUERY formatted as a string. Makes QUERY more readable, e.g. timestamp objects are replaced with human-readable strings." (cl-labels ((rec (form) (cl-typecase form (ts (ts-format form)) (cons (cons (rec (car form)) (rec (cdr form)))) (otherwise form)))) (format "%S" (rec query)))) (defun org-ql-view--font-lock-string (mode s) "Return string S font-locked according to MODE." ;; FIXME: Is this the proper way to do this? It works, but I feel like there must be a built-in way... (with-temp-buffer (delay-mode-hooks (insert s) (funcall mode) (font-lock-ensure) (buffer-string)))) (defun org-ql-view--buffer (&optional name) "Return `org-ql-view' buffer, creating it if necessary. If NAME is non-nil, return buffer by that name instead of using default buffer." (with-current-buffer (get-buffer-create (or name (concat org-ql-view-buffer-name-prefix "*"))) (unless (eq major-mode 'org-agenda-mode) (org-agenda-mode) (setf buffer-read-only t)) (current-buffer))) (defun org-ql-view--format-relative-date (difference) ;; MAYBE: Make this a `defsubst'. "Return relative date string for DIFFERENCE. DIFFERENCE should be an integer number of days, positive for dates in the past, and negative for dates in the future." (cond ((> difference 0) (format "%sd ago" difference)) ((< difference 0) (format "in %sd" (* -1 difference))) (t "today"))) ;;;; Transient ;; This section uses `transient' to allow the user to easily modify ;; and refresh views. ;; NOTE: I don't really know what I'm doing here. Even though the ;; Transient manual is written very well, not everything is covered in ;; it, so I'm having to try to imitate examples from `magit-transient'. (require 'transient) (defclass org-ql-view--variable (transient-variable) ;; FIXME: We don't need :scope, but maybe a slot has to be defined. ((scope :initarg :scope))) (cl-defmethod transient-infix-set ((obj org-ql-view--variable) value) "Set Org QL View variable defined by OBJ to VALUE." (let ((variable (oref obj variable))) (oset obj value value) (set (make-local-variable (oref obj variable)) value) (unless (or value transient--prefix) (message "Unset %s" variable)))) (define-transient-command org-ql-view-dispatch () "Show Org QL View dispatcher." [["Edit" ("t" org-ql-view--transient-title) ("q" org-ql-view--transient-query) ("i" org-ql-view--transient-in) ("s" org-ql-view--transient-sort) ("g" org-ql-view--transient-super-groups)]] [["View" ("r" "Refresh" org-ql-view-refresh) ("v" "Select" org-ql-view)] ["" ("C-s" "Save" org-ql-view-save) ("C-k" "Delete" org-ql-view-delete)]]) (defun org-ql-view--format-transient-key-value (key value) "Return KEY and VALUE formatted for display in Transient." ;; `window-width' minus 15 is about right. I think there's no way ;; to determine it automatically, because we can't know which column ;; Transient is starting at. (let ((max-width (- (window-width) 15))) (format "%s: %s" (propertize key 'face 'transient-argument) (s-truncate max-width (format "%s" value))))) (defun org-ql-view--format-transient-lisp-argument (key value) "Return KEY and VALUE (a Lisp object) formatted for display in Transient." ;; `window-width' minus 15 is about right. I think there's no way ;; to determine it automatically, because we can't know which column ;; Transient is starting at. (s-truncate (- (window-width) 15) (concat (propertize key 'face 'transient-argument) ": " (->> value org-ql-view--format-query (org-ql-view--font-lock-string 'emacs-lisp-mode))))) (define-infix-command org-ql-view--transient-title () ;; TODO: Add an asterisk or something when the view has been modified but not saved. :description (lambda () (org-ql-view--format-transient-key-value "Title" org-ql-view-title)) :class 'org-ql-view--variable :argument "" :variable 'org-ql-view-title :prompt "Title: " :reader (lambda (prompt _initial-input history) ;; FIXME: Figure out how to integrate initial-input. (read-string prompt (when org-ql-view-title (format "%s" org-ql-view-title)) history))) (define-infix-command org-ql-view--transient-query () :description (lambda () (org-ql-view--format-transient-lisp-argument "Query" org-ql-view-query)) :class 'org-ql-view--variable :argument "" :variable 'org-ql-view-query :prompt "Query: " :reader (lambda (prompt _initial-input history) ;; FIXME: Figure out how to integrate initial-input. (let ((query (read-string prompt (when org-ql-view-query (format "%S" org-ql-view-query)) history))) (if (or (string-prefix-p "(" query) (string-prefix-p "\"" query)) ;; Read sexp query. (read query) ;; Parse non-sexp query into sexp query. (org-ql--plain-query query))))) (define-infix-command org-ql-view--transient-in () :description (lambda () (org-ql-view--format-transient-lisp-argument "In buffers/files" org-ql-view-buffers-files)) :class 'org-ql-view--variable :argument "" :variable 'org-ql-view-buffers-files :prompt "Buffers/files: " :reader (lambda (_prompt _initial-input _history) ;; This doesn't use the Transient `initial-input' ;; argument, but it gives the same result. (org-ql-view--complete-buffers-files))) (define-infix-command org-ql-view--transient-super-groups () :description (lambda () (org-ql-view--format-transient-lisp-argument "Group by" org-ql-view-super-groups)) :class 'org-ql-view--variable :argument "" :variable 'org-ql-view-super-groups :prompt "Group by: " :reader (lambda (_prompt _initial-input _history) ;; FIXME: Figure out how to integrate initial-input and history. (org-ql-view--complete-super-groups))) (define-infix-command org-ql-view--transient-sort () :description (lambda () (org-ql-view--format-transient-lisp-argument "Sort by" (or org-ql-view-sort 'buffer-order))) :class 'org-ql-view--variable :argument "" :variable 'org-ql-view-sort :prompt "Sort: " :reader (lambda (_prompt _initial-input _history) ;; FIXME: Figure out how to integrate initial-input and history. (org-ql-view--complete-sort))) ;;;; Faces/properties (defun org-ql-view--format-element (element) ;; This essentially needs to do what `org-agenda-format-item' does, ;; which is a lot. We are a long way from that, but it's a start. "Return ELEMENT as a string with text-properties set by its property list. Its property list should be the second item in the list, as returned by `org-element-parse-buffer'. If ELEMENT is nil, return an empty string." (if (not element) "" (let* ((properties (cadr element)) ;; Remove the :parent property, which so bloats the size of ;; the properties list that it makes it essentially ;; impossible to debug, because Emacs takes approximately ;; forever to show it in the minibuffer or with ;; `describe-text-properties'. FIXME: Shouldn't be necessary ;; anymore since we're not parsing the whole buffer. ;; Also, remove ":" from key symbols. FIXME: It would be ;; better to avoid this somehow. At least, we should use a ;; function to convert plists to alists, if possible. (properties (cl-loop for (key val) on properties by #'cddr for symbol = (intern (cl-subseq (symbol-name key) 1)) unless (member symbol '(parent)) append (list symbol val))) ;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is ;; hidden by doing it through --add-faces (which calls --add-scheduled-face and ;; --add-deadline-face), and doing it in this form that gets the title hides it even more. ;; Adding the relative due date property should probably be done explicitly and separately ;; (which would also make it easier to do it independently of faces, etc). (title (--> (org-ql-view--add-faces element) (org-element-property :raw-value it) (org-link-display-format it))) (todo-keyword (-some--> (org-element-property :todo-keyword element) (org-ql-view--add-todo-face it))) ;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc. (tag-list (if org-use-tag-inheritance ;; FIXME: Note that tag inheritance cannot be used here unless markers are ;; added, otherwise we can't go to the item's buffer to look for inherited ;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I ;; forget...) (if-let ((marker (or (org-element-property :org-hd-marker element) (org-element-property :org-marker element)))) (with-current-buffer (marker-buffer marker) ;; I wish `org-get-tags' used the correct buffer automatically. (org-get-tags marker (not org-use-tag-inheritance))) ;; No marker found (warn "No marker found for item: %s" title) (org-element-property :tags element)) (org-element-property :tags element))) (tag-string (when tag-list (--> tag-list (s-join ":" it) (s-wrap it ":") (org-add-props it nil 'face 'org-tag)))) ;; (category (org-element-property :category element)) (priority-string (-some->> (org-element-property :priority element) (char-to-string) (format "[#%s]") (org-ql-view--add-priority-face))) (habit-property (org-with-point-at (org-element-property :begin element) (when (org-is-habit-p) (org-habit-parse-todo)))) (due-string (pcase (org-element-property :relative-due-date element) ('nil "") (string (format " %s " (org-add-props string nil 'face 'org-ql-view-due-date))))) (string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string))))) (remove-list-of-text-properties 0 (length string) '(line-prefix) string) ;; Add all the necessary properties and faces to the whole string (--> string ;; FIXME: Use proper prefix (concat " " it) (org-add-props it properties 'org-agenda-type 'search 'todo-state todo-keyword 'tags tag-list 'org-habit-p habit-property))))) (defun org-ql-view--add-faces (element) "Return ELEMENT with deadline and scheduled faces added." (->> element (org-ql-view--add-scheduled-face) (org-ql-view--add-deadline-face))) (defun org-ql-view--add-priority-face (string) "Return STRING with priority face added." (when (string-match "\\(\\[#\\(.\\)\\]\\)" string) (let ((face (org-get-priority-face (string-to-char (match-string 2 string))))) (org-add-props string nil 'face face 'font-lock-fontified t)))) (defun org-ql-view--add-scheduled-face (element) "Add faces to ELEMENT's title for its scheduled status." ;; NOTE: Also adding prefix (if-let ((scheduled-date (org-element-property :scheduled element))) (let* ((todo-keyword (org-element-property :todo-keyword element)) (today-day-number (org-today)) ;; (current-day-number ;; NOTE: Not currently used, but if we ever implement a more "traditional" agenda that ;; shows perspective of multiple days at once, we'll need this, so I'll leave it for now. ;; ;; FIXME: This is supposed to be the, shall we say, ;; ;; pretend, or perspective, day number that this pass ;; ;; through the agenda is being made for. We need to ;; ;; either set this in the calling function, set it here, ;; ;; or accomplish this in a different way. See ;; ;; `org-agenda-get-scheduled' and where `date' is set in ;; ;; `org-agenda-list'. ;; today-day-number) (scheduled-day-number (org-time-string-to-absolute (org-element-timestamp-interpreter scheduled-date 'ignore))) (difference-days (- today-day-number scheduled-day-number)) (relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil 'help-echo (org-element-property :raw-value scheduled-date))) ;; FIXME: Unused for now: ;; (show-all (or (eq org-agenda-repeating-timestamp-show-all t) ;; (member todo-keyword org-agenda-repeating-timestamp-show-all))) ;; FIXME: Unused for now: (sexp-p (string-prefix-p "%%" raw-value)) ;; FIXME: Unused for now: (raw-value (org-element-property :raw-value scheduled-date)) ;; FIXME: I don't remember what `repeat-day-number' was for, but we aren't using it. ;; But I'll leave it here for now. ;; (repeat-day-number (cond (sexp-p (org-time-string-to-absolute scheduled-date)) ;; ((< today-day-number scheduled-day-number) scheduled-day-number) ;; (t (org-time-string-to-absolute ;; raw-value ;; (if show-all ;; current-day-number ;; today-day-number) ;; 'future ;; ;; FIXME: I don't like ;; ;; calling `current-buffer' ;; ;; here. If the element has ;; ;; a marker, we should use ;; ;; that. ;; (current-buffer) ;; (org-element-property :begin element))))) (face (cond ((member todo-keyword org-done-keywords) 'org-agenda-done) ((= today-day-number scheduled-day-number) 'org-scheduled-today) ((> today-day-number scheduled-day-number) 'org-scheduled-previously) (t 'org-scheduled))) (title (--> (org-element-property :raw-value element) (org-add-props it nil 'face face))) (properties (--> (cadr element) (plist-put it :title title) (plist-put it :relative-due-date relative-due-date)))) (list (car element) properties)) ;; Not scheduled element)) (defun org-ql-view--add-deadline-face (element) "Add faces to ELEMENT's title for its deadline status. Also store relative due date as string in `:relative-due-date' property." ;; FIXME: In my config, doesn't apply orange for approaching deadline the same way the Org Agenda does. (if-let ((deadline-date (org-element-property :deadline element))) (let* ((today-day-number (org-today)) (deadline-day-number (org-time-string-to-absolute (org-element-timestamp-interpreter deadline-date 'ignore))) (difference-days (- today-day-number deadline-day-number)) (relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil 'help-echo (org-element-property :raw-value deadline-date))) ;; FIXME: Unused for now: (todo-keyword (org-element-property :todo-keyword element)) ;; FIXME: Unused for now: (done-p (member todo-keyword org-done-keywords)) ;; FIXME: Unused for now: (today-p (= today-day-number deadline-day-number)) (deadline-passed-fraction (--> (- deadline-day-number today-day-number) (float it) (/ it (max org-deadline-warning-days 1)) (- 1 it))) (face (org-agenda-deadline-face deadline-passed-fraction)) (title (--> (org-element-property :raw-value element) (org-add-props it nil 'face face))) (properties (--> (cadr element) (plist-put it :title title) (plist-put it :relative-due-date relative-due-date)))) (list (car element) properties)) ;; No deadline element)) (defun org-ql-view--add-todo-face (keyword) "Return KEYWORD with Org to-do face added." (let* ((org-done-keywords org-done-keywords-for-agenda) (face (org-get-todo-face keyword))) (when face (add-text-properties 0 (length keyword) (list 'face face) keyword)) keyword)) ;;;;; Completion (defun org-ql-view--contract-buffers-files (buffers-files) "Return BUFFERS-FILES in its \"contracted\" form. The contracted form is \"org-agenda-files\" if BUFFERS-FILES matches the value of `org-agenda-files' (either the function or the variable), \"org-directory\" if it matches the value of `org-ql-search-directories-files', or \"buffer\" if it is the current buffer. Otherwise BUFFERS-FILES is returned unchanged." ;; Used in `org-ql-view--complete-buffers-files' and ;; `org-ql-view--header-line-format'. (cl-labels ((expand-files (list) (--map (cl-typecase it (string (expand-file-name it)) (otherwise it)) list))) ;; TODO: Test this more exhaustively. (pcase buffers-files ((pred listp) (pcase (expand-files buffers-files) ((or (pred (seq-set-equal-p (mapcar #'expand-file-name (org-agenda-files)))) (pred (seq-set-equal-p (mapcar #'expand-file-name org-agenda-files)))) "org-agenda-files") ((pred (seq-set-equal-p (org-ql-search-directories-files))) "org-directory") (_ (let ((print-length nil)) (concat "'" (prin1-to-string buffers-files)))))) ((pred (equal (current-buffer))) "buffer") ((or 'org-agenda-files '(function org-agenda-files)) "org-agenda-files") (_ (let ((print-length nil)) (prin1-to-string buffers-files)))))) (defun org-ql-view--complete-buffers-files () "Return value for `org-ql-view-buffers-files' using completion." (cl-labels ((initial-input () (when org-ql-view-buffers-files (org-ql-view--contract-buffers-files org-ql-view-buffers-files)))) (if (and org-ql-view-buffers-files (bufferp org-ql-view-buffers-files)) ;; Buffers can't be input by name, so if the default value is a buffer, just use it. ;; TODO: Find a way to fix this. org-ql-view-buffers-files (pcase-exhaustive (completing-read "Buffers/Files: " (list 'buffer 'org-agenda-files 'org-directory 'all) nil nil (initial-input)) ((or "" "buffer") (current-buffer)) ("org-agenda-files" (org-agenda-files)) ("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode) (buffer-list))) ("org-directory" (org-ql-search-directories-files)) ((and form (guard (rx bos "("))) (-flatten (eval (read form)))) (else (s-split (rx (1+ space)) else)))))) (defun org-ql-view--complete-super-groups () "Return value for `org-ql-view-super-groups' using completion." (when (bound-and-true-p org-super-agenda-auto-selector-keywords) (let ((keywords (cl-loop for type in org-super-agenda-auto-selector-keywords collect (substring (symbol-name type) 6)))) (pcase (completing-read "Group by: " (append (list "Don't group" "Global super-groups") keywords) nil nil (when org-ql-view-super-groups (format "%S" org-ql-view-super-groups))) ("Global super-groups" org-super-agenda-groups) ((or "" "Don't group") nil) ((and keyword (guard (member keyword keywords))) (list (list (intern (concat ":auto-" keyword))))) (else (read else)))))) (defun org-ql-view--complete-sort () "Return value for `org-ql-view-sort' using completion." ;; Use space to separate sorting predicates, not comma. (let* ((crm-separator (rx space)) (crm-local-completion-map (let ((map (copy-keymap crm-local-completion-map))) (define-key map (kbd "SPC") nil) map)) (input (->> (completing-read-multiple "Sort by: " (list "buffer-order" "date" "deadline" "priority" "scheduled" "todo") nil nil (when org-ql-view-sort (prin1-to-string org-ql-view-sort))) (--remove (equal "buffer-order" it))))) (pcase input ('nil nil) ((and (pred listp) sort) ;; Multiple sorters. (mapcar #'intern sort)) (sort ;; One sorter. (intern sort))))) ;;;; Footer (provide 'org-ql-view) ;;; org-ql-view.el ends here