From 0ff109ed102b8f1cbfe25d2cdf481978a3044a86 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sat, 7 Sep 2019 12:36:50 -0500 Subject: [PATCH 1/7] WIP: view sections --- org-ql-view-section.el | 417 ++++++++++++++++++++++++++++++++++++ test-org-ql-view-section.el | 130 +++++++++++ 2 files changed, 547 insertions(+) create mode 100644 org-ql-view-section.el create mode 100644 test-org-ql-view-section.el diff --git a/org-ql-view-section.el b/org-ql-view-section.el new file mode 100644 index 0000000..d531dd8 --- /dev/null +++ b/org-ql-view-section.el @@ -0,0 +1,417 @@ +;;; org-ql-view-section.el --- Magit-section-like views for Org -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 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: + +;; Inspired by `magit-section'. + +;;; Code: + +;;;; Requirements + +(require 'eieio) + +(require 's) + +;;;; Macros + +(defmacro org-ql-defkeymap (name copy docstring &rest maps) + "Define a new keymap variable (using `defvar'). + +NAME is a symbol, which will be the new variable's symbol. COPY +may be a keymap which will be copied, or nil, in which case the +new keymap will be sparse. DOCSTRING is the docstring for +`defvar'. + +MAPS is a sequence of alternating key-value pairs. The keys may +be a string, in which case they will be passed as arguments to +`kbd', or a raw key sequence vector. The values may be lambdas +or function symbols, as would be normally passed to +`define-key'." + (declare (indent defun)) + (let* ((map (if copy + (copy-keymap copy) + (make-sparse-keymap (prin1-to-string name))))) + (cl-loop for (key fn) on maps by #'cddr + do (progn + (when (stringp key) + (setq key (kbd key))) + (define-key map key fn))) + `(defvar ,name ',map ,docstring))) + +(defmacro org-ql-defclass (name superclasses slots &rest options-and-doc) + ;; Copied from `defclass*' in elexandria.el. + ;; MAYBE: Change instance-initform to instance-init. This would no longer set + ;; the slot to the value of the expression, but would just evaluate it. The + ;; expression could set the slot value with `setq' if necessary. + "Like `defclass', but supports instance initforms. +Each slot may have an `:instance-initform', which is evaluated in +the context of the object's slots when each instance is +initialized, similar to Python's __init__ method." + ;; TODO: Add option to set all slots' initforms (e.g. to set them all to nil). + (declare (indent defun)) + (let* ((slot-inits (-non-nil (--map (let ((name (car it)) + (initer (plist-get (cdr it) :instance-initform))) + (when initer + (list 'setq name initer))) + slots))) + (slot-names (mapcar #'car slots)) + ;; FIXME: `around-fn-name' is unused. + ;; (around-fn-name (intern (concat (symbol-name name) "-initialize"))) + (docstring (format "Inititalize instance of %s." name))) + `(progn + (defclass ,name ,superclasses ,slots ,@options-and-doc) + (when (> (length ',slot-inits) 0) + (cl-defmethod initialize-instance :after ((this ,name) &rest _) + ,docstring + (with-slots ,slot-names this + ,@slot-inits)))))) + +(cl-defmacro org-ql-defstruct (&rest args) + ;; Copied from `ts-defstruct'. + "Like `cl-defstruct', but with additional slot options. + +Additional slot options and values: + +`:accessor-init': a sexp that initializes the slot in the +accessor if the slot is nil. The symbol `struct' will be bound +to the current struct. The accessor is defined after the struct +is fully defined, so it may refer to the struct +definition (e.g. by using the `cl-struct' `pcase' macro). + +`:aliases': A list of symbols which will be aliased to the slot +accessor, prepended with the struct name (e.g. a struct `ts' with +slot `year' and alias `y' would create an alias `ts-y')." + (declare (indent defun)) + ;; FIXME: Compiler warnings about accessors defined multiple times. Not sure if we can fix this + ;; except by ignoring warnings. + (let* ((struct-name (car args)) + (struct-slots (cdr args)) + (cl-defstruct-expansion (macroexpand `(cl-defstruct ,struct-name ,@struct-slots))) + accessor-forms alias-forms) + (cl-loop for slot in struct-slots + for pos from 1 + when (listp slot) + do (-let* (((slot-name _slot-default . slot-options) slot) + ((&keys :accessor-init :aliases) slot-options) + (accessor-name (intern (concat (symbol-name struct-name) "-" (symbol-name slot-name)))) + (accessor-docstring (format "Access slot \"%s\" of `%s' struct STRUCT." + slot-name struct-name)) + (struct-pred (intern (concat (symbol-name struct-name) "-p"))) + ;; Accessor form copied from macro expansion of `cl-defstruct'. + (accessor-form `(cl-defsubst ,accessor-name (struct) + ,accessor-docstring + ;; FIXME: side-effect-free is probably not true here, but what about error-free? + ;; (declare (side-effect-free error-free)) + (or (,struct-pred struct) + (signal 'wrong-type-argument + (list ',struct-name struct))) + ,(when accessor-init + `(unless (aref struct ,pos) + (aset struct ,pos ,accessor-init))) + ;; NOTE: It's essential that this `aref' form be last + ;; so the gv-setter works in the compiler macro. + (aref struct ,pos)))) + (push accessor-form accessor-forms) + ;; Remove accessor forms from `cl-defstruct' expansion. This may be distasteful, + ;; but it would seem more distasteful to copy all of `cl-defstruct' and potentially + ;; have the implementations diverge in the future when Emacs changes (e.g. the new + ;; record type). + (cl-loop for form in-ref cl-defstruct-expansion + do (pcase form + (`(cl-defsubst ,(and accessor (guard (eq accessor accessor-name))) + . ,_) + accessor ; Silence "unused lexical variable" warning. + (setf form nil)))) + ;; Alias definitions. + (cl-loop for alias in aliases + for alias-name = (intern (concat (symbol-name struct-name) "-" (symbol-name alias))) + do (push `(defalias ',alias-name ',accessor-name) alias-forms)) + ;; TODO: Setter + ;; ,(when (plist-get slot-options :reset) + ;; `(gv-define-setter ,accessor-name (ts value) + ;; `(progn + ;; (aset ,ts ,,pos ,value) + ;; (setf (ts-unix ts) ni)))) + )) + `(progn + ,cl-defstruct-expansion + ,@accessor-forms + ,@alias-forms))) + +;;;; Variables + +(defvar org-ql-view-section-depth -1 + "Depth of current section. +Used in `org-ql-view-string'.") + +(org-ql-defkeymap org-ql-view-map nil + "Map for `org-ql-view' maps." + [tab] org-ql-view-section-toggle) + +;;;; Classes + +(org-ql-defclass org-ql-view-section () + ;; TODO: Decide/clarify whether beg/end should/can be markers. + ;; NOTE: Not using initforms for now. + ((beg :initarg :beg + :documentation "Position or marker at which section begins in buffer.") + (end :initarg :end + :documentation "Position or marker at which section ends in buffer.") + (header :initarg :header + :documention "Optional header string.") + (contents-beg :initarg :contents-beg + :documentation "Position or marker at which section's contents begins in buffer (i.e. where the header ends).") + (items :initarg :items + :documentation "List of items the section contains.") + (keymap :initarg :keymap + :instance-initform org-ql-view-map + :documentation "Keymap used inside section.") + (collapsed :initarg :collapsed + :initform nil + :documentation "Whether the section is collapsed."))) + +;;;; Structs + +(org-ql-defstruct org-ql-item + buffer marker beg category level todo priority heading tags deadline-element scheduled-element properties + (deadline-ts nil :accessor-init (when-let* ((element (org-ql-item-deadline-element struct))) + (ts-parse-org-element element))) + (scheduled-ts nil :accessor-init (when-let* ((element (org-ql-item-scheduled-element struct))) + (ts-parse-org-element element)))) + +;;;; Customization + +(defgroup org-ql-view nil + "Options for `org-ql' views." + :group 'org-ql) + +(defcustom org-ql-view-item-indent " " + "String used to indent individual items." + :type 'string) + +(defcustom org-ql-view-item-indent-per-level 4 + "Number of spaces used to indent items at each levep." + :type 'integer) + +;;;; Commands + +(defun org-ql-view-section-toggle (section) + "Toggle SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed) section + (if collapsed + (org-ql-section-expand section) + (org-ql-section-collapse section))))) + +(defun org-ql-section-collapse (section) + "Collapse SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed contents-beg end) section + (setf collapsed t) + (let ((ov (make-overlay contents-beg end))) + ;; I don't know if `evaporate' is necessary, but `magit-section' does it. + (overlay-put ov 'evaporate t) + (overlay-put ov 'invisible t))))) + +(defun org-ql-section-expand (section) + "Expand SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed contents-beg end) section + (setf collapsed nil) + (remove-overlays contents-beg end 'invisible t)))) + +;;;; Methods + +(cl-defmethod org-ql-view-insert ((section org-ql-view-section) &key group-by) + "Insert SECTION into current buffer." + (cl-labels ((group (items fns &key parent-header) + (setf items (-group-by (car fns) items)) + (if (cdr fns) + (--map (org-ql-view-section + :header (car it) + :items (group (cdr it) (cdr fns) :parent-header (car it))) + items) + (cond ((assoc nil items) + (append (--map (org-ql-view-section + :header (car it) + :items (cdr it)) + (butlast items)) + (cdr (assoc nil items)))) + (t (--map (org-ql-view-section + :header (car it) + :items (cdr it)) + items)))))) + (with-slots (beg end header contents-beg items keymap) section + (let* ((org-ql-view-section-depth (1+ org-ql-view-section-depth)) + (org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level + org-ql-view-section-depth) + " "))) + (when group-by + (setf items (group items group-by))) + (setf beg (point)) + (insert org-ql-view-item-indent (org-ql-view-header section)) + (put-text-property beg (point) :org-ql-view-section section) + (setf contents-beg (point)) + (let* ((org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level + (1+ org-ql-view-section-depth)) + " "))) + (dolist (item items) + (insert "\n") + (cl-typecase item + (org-ql-view-section (org-ql-view-insert item)) + (list (--each item + (insert "\n") + (org-ql-view-insert it))) + (otherwise (org-ql-view-insert item)) + ))) + (setf end (point)) + (put-text-property beg (point) 'keymap keymap))))) + +;; (cl-defmethod org-ql-view-insert ((sections list)) +;; "Insert SECTIONS into current buffer." +;; (let* ((org-ql-view-section-depth (1+ org-ql-view-section-depth))) +;; (dolist (section sections) +;; (insert "\n") +;; (org-ql-view-insert section)))) +(cl-defmethod org-ql-view-insert ((sections list)) + "Insert SECTIONS into current buffer." + (error "OOPS")) + +(cl-defmethod org-ql-view-header ((section org-ql-view-section)) + "Return header string for SECTION. +Does not include newline." + (cl-labels ((num-items (items) + (cl-loop for item in items + sum (cl-typecase item + (org-ql-view-section (num-items (oref item items))) + (list (cl-loop for section in item + sum (num-items (oref section items)))) + (otherwise 1))))) + (with-slots (header items) section + (concat (propertize (format "%s" + (or header "Section")) + 'face 'magit-section-heading) + " (" (number-to-string (num-items items)) ")")))) + +(cl-defmethod org-ql-view-insert ((item org-ql-item)) + "Insert ITEM into current buffer. +Does not insert newline." + (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item) + (todo (when todo + (propertize todo 'face (org-get-todo-face todo)))) + (priority (when priority + (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)))) + (tags (when tags + (propertize (s-join ":" tags) 'face 'org-tag-group) + )) + (beg (point))) + (insert org-ql-view-item-indent) + (when todo + (insert todo " ")) + (when priority + (insert priority " ")) + (when heading + (insert heading " ")) + (when tags + (insert tags)) + (put-text-property beg (point) :org-ql-view-section item))) + +(cl-defmethod org-ql-view-insert ((item string)) + "Insert ITEM into current buffer." + (insert item)) + +;;;; Functions + +(cl-defun org-ql-view-section-at (&optional (pos (point-at-bol))) + (get-text-property pos :org-ql-view-section)) + +(defun org-ql-item-at () + ;; FIXME: Put this function elsewhere. + "Return `org-ql-item' for entry at point." + (-let* (((_ (&plist :begin :level :raw-value :priority :tags :todo-keyword :deadline :scheduled :CATEGORY)) + (org-element-headline-parser (line-end-position)))) + (make-org-ql-item :beg begin + :category CATEGORY + :level level + :todo todo-keyword + :priority (when priority + (char-to-string priority)) + :heading raw-value + :tags tags + :deadline-element deadline + :scheduled-element scheduled))) + +(defun org-ql-view-sort-todo (items) + "Return ITEMS sorted by to-do keyword, in to-do keyword order. +Uses `org-todo-keywords', which does not include buffer-local +keywords." + (cl-flet ((keyword (string) + ;; Return keyword without parenthesized options. + (unless (string= string "|") + (if (string-match (rx (group (minimal-match (1+ anything))) + "(" (1+ anything) ")") + string) + (match-string 1 string) + string)))) + (let ((keywords (cl-loop with non-done-keywords with done-keywords + for (_type . keywords) in (reverse org-todo-keywords) + for non-done = (->> keywords + (--take-while (not (string= it "|"))) + (-map #'keyword)) + for done = (-map #'keyword + (-slice keywords + (1+ (or (--find-index (string= it "|") + keywords) + -1)))) + do (progn + (setf non-done-keywords (append non-done non-done-keywords)) + (setf done-keywords (append done done-keywords))) + finally return (append non-done-keywords done-keywords)))) + (-sort (lambda (a b) + (cond ((and (org-ql-item-todo a) + (org-ql-item-todo b)) + (< (or (cl-position (org-ql-item-todo a) keywords :test #'string=) 0) + (or (cl-position (org-ql-item-todo b) keywords :test #'string=) 0))) + ((org-ql-item-todo a) t) + ((org-ql-item-todo b) nil))) + items)))) + + +(defun org-ql-view-sort-planning (items) + "Return ITEMS sorted by planning date." + (cl-flet ((planning-ts (item) + (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)))) + (sort items (lambda (a b) + (let ((a-ts (planning-ts a)) + (b-ts (planning-ts b))) + (cond ((and a-ts b-ts) + (ts< a-ts b-ts)) + (a-ts t) + (b-ts nil))))))) + +;;;; Footer + +(provide 'org-ql-view-section) + +;;; org-ql-view-section.el ends here diff --git a/test-org-ql-view-section.el b/test-org-ql-view-section.el new file mode 100644 index 0000000..d6da8f1 --- /dev/null +++ b/test-org-ql-view-section.el @@ -0,0 +1,130 @@ +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (sub-section1 (org-ql-view-section + :items (list (make-org-ql-item :level 1 + :todo "TODO" + :priority "A" + :heading "Alpha" + :tags '("one" "two")) + (make-org-ql-item :level 1 + :todo "NEXT" + :priority "B" + :heading "Bravo" + :tags '("one" "two" "three"))))) + (sub-section2 (org-ql-view-section + :items (list (make-org-ql-item :level 1 + :todo "MAYBE" + :heading "Charlie" + :tags '("one" "two")) + (make-org-ql-item :level 1 + :todo "SOMEDAY" + :heading "Delta" + :tags '("one" "two" "three"))))) + (top-section (org-ql-view-section + :items (list sub-section1 sub-section2))) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section) + (pop-to-buffer buffer))) + +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-todo))) + (top-section (org-ql-view-section + :header (format "To-Do (%s)" (length items)) + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by '(org-ql-item-todo org-ql-item-priority)) + (pop-to-buffer buffer))) + +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-planning))) + (top-section (org-ql-view-section + :header (format "To-Do (%s)" (length items)) + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by (list (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%Y-%m-%d" it))))) + (pop-to-buffer buffer))) +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-planning))) + (top-section (org-ql-view-section + :header "To-Do by Planning Date" + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by (list (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%B %Y" it))) + (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%d %B" it))))) + (pop-to-buffer buffer))) +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-planning))) + (top-section (org-ql-view-section + :header "To-Do by Planning Date" + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by (list 'org-ql-item-todo + (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%B %Y" it))) + (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%d %B" it))) + )) + (pop-to-buffer buffer))) +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-planning))) + (top-section (org-ql-view-section + :header "To-Do by Planning Date" + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by (list 'org-ql-item-todo + (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%B %Y" it))) + + )) + (pop-to-buffer buffer))) From d0705dce0b1645e5e3e1aef261252f6bce156225 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sat, 7 Sep 2019 17:43:25 -0500 Subject: [PATCH 2/7] WIP --- org-ql-view-section.el | 16 +++++----------- test-org-ql-view-section.el | 23 +++++++++++++++++++++++ 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/org-ql-view-section.el b/org-ql-view-section.el index d531dd8..cff02a9 100644 --- a/org-ql-view-section.el +++ b/org-ql-view-section.el @@ -33,6 +33,7 @@ ;;;; Macros (defmacro org-ql-defkeymap (name copy docstring &rest maps) + ;; Copied from `defkeymap' in elexandria.el. "Define a new keymap variable (using `defvar'). NAME is a symbol, which will be the new variable's symbol. COPY @@ -310,7 +311,7 @@ Does not include newline." (otherwise 1))))) (with-slots (header items) section (concat (propertize (format "%s" - (or header "Section")) + (or header "None")) 'face 'magit-section-heading) " (" (number-to-string (num-items items)) ")")))) @@ -318,23 +319,16 @@ Does not include newline." "Insert ITEM into current buffer. Does not insert newline." (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item) - (todo (when todo - (propertize todo 'face (org-get-todo-face todo)))) - (priority (when priority - (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)))) - (tags (when tags - (propertize (s-join ":" tags) 'face 'org-tag-group) - )) (beg (point))) (insert org-ql-view-item-indent) (when todo - (insert todo " ")) + (insert (propertize todo 'face (org-get-todo-face todo)) " ")) (when priority - (insert priority " ")) + (insert (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)) " ")) (when heading (insert heading " ")) (when tags - (insert tags)) + (insert (propertize (s-join ":" tags) 'face 'org-tag-group))) (put-text-property beg (point) :org-ql-view-section item))) (cl-defmethod org-ql-view-insert ((item string)) diff --git a/test-org-ql-view-section.el b/test-org-ql-view-section.el index d6da8f1..80c927a 100644 --- a/test-org-ql-view-section.el +++ b/test-org-ql-view-section.el @@ -107,6 +107,29 @@ (ts-format "%d %B" it))) )) (pop-to-buffer buffer))) +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-planning))) + (top-section (org-ql-view-section + :header "To-Do by Planning Date" + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by (list (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%B %Y" it))) + (lambda (item) + (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) + (ts-format "%d %B" it))) + 'org-ql-item-todo + )) + (pop-to-buffer buffer))) (let* ((buffer (get-buffer-create "test-org-ql-view-section")) (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" '(todo) From 5a4422079a53db3cff307eba51b0a489a71ce209 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sat, 7 Sep 2019 18:02:21 -0500 Subject: [PATCH 3/7] WIP: Rearranging --- org-ql-item.el | 124 +++++++ org-ql-macros.el | 164 +++++++++ org-ql-view-section.el | 411 --------------------- org-ql-view.el | 707 ++++++++---------------------------- test-org-ql-view-section.el | 3 + 5 files changed, 449 insertions(+), 960 deletions(-) create mode 100644 org-ql-item.el create mode 100644 org-ql-macros.el delete mode 100644 org-ql-view-section.el diff --git a/org-ql-item.el b/org-ql-item.el new file mode 100644 index 0000000..bed8358 --- /dev/null +++ b/org-ql-item.el @@ -0,0 +1,124 @@ +;;; org-ql-item.el --- Item parsing for org-ql results -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Adam Porter + +;; Author: Adam Porter + +;; 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 'org) +(require 'org-element) + +(require 'dash) + +(require 'org-ql-macros) + +;;;; Structs + +(org-ql-defstruct org-ql-item + buffer marker beg category level todo priority heading tags deadline-element scheduled-element properties + (deadline-ts nil :accessor-init (when-let* ((element (org-ql-item-deadline-element struct))) + (ts-parse-org-element element))) + (scheduled-ts nil :accessor-init (when-let* ((element (org-ql-item-scheduled-element struct))) + (ts-parse-org-element element)))) + +;;;; Variables + + +;;;; Customization + + +;;;; Commands + + +;;;; Functions + +(defun org-ql-item-at () + "Return `org-ql-item' for entry at point." + (-let* (((_ (&plist :begin :level :raw-value :priority :tags :todo-keyword :deadline :scheduled :CATEGORY)) + (org-element-headline-parser (line-end-position)))) + (make-org-ql-item :beg begin + :category CATEGORY + :level level + :todo todo-keyword + :priority (when priority + (char-to-string priority)) + :heading raw-value + :tags tags + :deadline-element deadline + :scheduled-element scheduled))) + +;;;;; Sorting + +(defun org-ql-item--sort-planning (items) + "Return ITEMS sorted by planning date." + (cl-flet ((planning-ts (item) + (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)))) + (sort items (lambda (a b) + (let ((a-ts (planning-ts a)) + (b-ts (planning-ts b))) + (cond ((and a-ts b-ts) + (ts< a-ts b-ts)) + (a-ts t) + (b-ts nil))))))) + +(defun org-ql-item--sort-todo (items) + "Return ITEMS sorted by to-do keyword, in to-do keyword order. +Uses `org-todo-keywords', which does not include buffer-local +keywords." + (cl-flet ((keyword (string) + ;; Return keyword without parenthesized options. + (unless (string= string "|") + (if (string-match (rx (group (minimal-match (1+ anything))) + "(" (1+ anything) ")") + string) + (match-string 1 string) + string)))) + (let ((keywords (cl-loop with non-done-keywords with done-keywords + for (_type . keywords) in (reverse org-todo-keywords) + for non-done = (->> keywords + (--take-while (not (string= it "|"))) + (-map #'keyword)) + for done = (-map #'keyword + (-slice keywords + (1+ (or (--find-index (string= it "|") + keywords) + -1)))) + do (progn + (setf non-done-keywords (append non-done non-done-keywords)) + (setf done-keywords (append done done-keywords))) + finally return (append non-done-keywords done-keywords)))) + (-sort (lambda (a b) + (cond ((and (org-ql-item-todo a) + (org-ql-item-todo b)) + (< (or (cl-position (org-ql-item-todo a) keywords :test #'string=) 0) + (or (cl-position (org-ql-item-todo b) keywords :test #'string=) 0))) + ((org-ql-item-todo a) t) + ((org-ql-item-todo b) nil))) + items)))) + +;;;; Footer + +(provide 'org-ql-item) + +;;; org-ql-item.el ends here diff --git a/org-ql-macros.el b/org-ql-macros.el new file mode 100644 index 0000000..1dd6cde --- /dev/null +++ b/org-ql-macros.el @@ -0,0 +1,164 @@ +;;; org-ql-macros.el --- Macros used in org-ql -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Adam Porter + +;; Author: Adam Porter + +;; 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 'eieio) + +(require 'dash) + +;;;; Macros + +(defmacro org-ql-defkeymap (name copy docstring &rest maps) + ;; Copied from `defkeymap' in elexandria.el. + "Define a new keymap variable (using `defvar'). + +NAME is a symbol, which will be the new variable's symbol. COPY +may be a keymap which will be copied, or nil, in which case the +new keymap will be sparse. DOCSTRING is the docstring for +`defvar'. + +MAPS is a sequence of alternating key-value pairs. The keys may +be a string, in which case they will be passed as arguments to +`kbd', or a raw key sequence vector. The values may be lambdas +or function symbols, as would be normally passed to +`define-key'." + (declare (indent defun)) + (let* ((map (if copy + (copy-keymap copy) + (make-sparse-keymap (prin1-to-string name))))) + (cl-loop for (key fn) on maps by #'cddr + do (progn + (when (stringp key) + (setq key (kbd key))) + (define-key map key fn))) + `(defvar ,name ',map ,docstring))) + +(defmacro org-ql-defclass (name superclasses slots &rest options-and-doc) + ;; Copied from `defclass*' in elexandria.el. + ;; MAYBE: Change instance-initform to instance-init. This would no longer set + ;; the slot to the value of the expression, but would just evaluate it. The + ;; expression could set the slot value with `setq' if necessary. + "Like `defclass', but supports instance initforms. +Each slot may have an `:instance-initform', which is evaluated in +the context of the object's slots when each instance is +initialized, similar to Python's __init__ method." + ;; TODO: Add option to set all slots' initforms (e.g. to set them all to nil). + (declare (indent defun)) + (let* ((slot-inits (-non-nil (--map (let ((name (car it)) + (initer (plist-get (cdr it) :instance-initform))) + (when initer + (list 'setq name initer))) + slots))) + (slot-names (mapcar #'car slots)) + ;; FIXME: `around-fn-name' is unused. + ;; (around-fn-name (intern (concat (symbol-name name) "-initialize"))) + (docstring (format "Inititalize instance of %s." name))) + `(progn + (defclass ,name ,superclasses ,slots ,@options-and-doc) + (when (> (length ',slot-inits) 0) + (cl-defmethod initialize-instance :after ((this ,name) &rest _) + ,docstring + (with-slots ,slot-names this + ,@slot-inits)))))) + +(cl-defmacro org-ql-defstruct (&rest args) + ;; Copied from `ts-defstruct'. + "Like `cl-defstruct', but with additional slot options. + +Additional slot options and values: + +`:accessor-init': a sexp that initializes the slot in the +accessor if the slot is nil. The symbol `struct' will be bound +to the current struct. The accessor is defined after the struct +is fully defined, so it may refer to the struct +definition (e.g. by using the `cl-struct' `pcase' macro). + +`:aliases': A list of symbols which will be aliased to the slot +accessor, prepended with the struct name (e.g. a struct `ts' with +slot `year' and alias `y' would create an alias `ts-y')." + (declare (indent defun)) + ;; FIXME: Compiler warnings about accessors defined multiple times. Not sure if we can fix this + ;; except by ignoring warnings. + (let* ((struct-name (car args)) + (struct-slots (cdr args)) + (cl-defstruct-expansion (macroexpand `(cl-defstruct ,struct-name ,@struct-slots))) + accessor-forms alias-forms) + (cl-loop for slot in struct-slots + for pos from 1 + when (listp slot) + do (-let* (((slot-name _slot-default . slot-options) slot) + ((&keys :accessor-init :aliases) slot-options) + (accessor-name (intern (concat (symbol-name struct-name) "-" (symbol-name slot-name)))) + (accessor-docstring (format "Access slot \"%s\" of `%s' struct STRUCT." + slot-name struct-name)) + (struct-pred (intern (concat (symbol-name struct-name) "-p"))) + ;; Accessor form copied from macro expansion of `cl-defstruct'. + (accessor-form `(cl-defsubst ,accessor-name (struct) + ,accessor-docstring + ;; FIXME: side-effect-free is probably not true here, but what about error-free? + ;; (declare (side-effect-free error-free)) + (or (,struct-pred struct) + (signal 'wrong-type-argument + (list ',struct-name struct))) + ,(when accessor-init + `(unless (aref struct ,pos) + (aset struct ,pos ,accessor-init))) + ;; NOTE: It's essential that this `aref' form be last + ;; so the gv-setter works in the compiler macro. + (aref struct ,pos)))) + (push accessor-form accessor-forms) + ;; Remove accessor forms from `cl-defstruct' expansion. This may be distasteful, + ;; but it would seem more distasteful to copy all of `cl-defstruct' and potentially + ;; have the implementations diverge in the future when Emacs changes (e.g. the new + ;; record type). + (cl-loop for form in-ref cl-defstruct-expansion + do (pcase form + (`(cl-defsubst ,(and accessor (guard (eq accessor accessor-name))) + . ,_) + accessor ; Silence "unused lexical variable" warning. + (setf form nil)))) + ;; Alias definitions. + (cl-loop for alias in aliases + for alias-name = (intern (concat (symbol-name struct-name) "-" (symbol-name alias))) + do (push `(defalias ',alias-name ',accessor-name) alias-forms)) + ;; TODO: Setter + ;; ,(when (plist-get slot-options :reset) + ;; `(gv-define-setter ,accessor-name (ts value) + ;; `(progn + ;; (aset ,ts ,,pos ,value) + ;; (setf (ts-unix ts) ni)))) + )) + `(progn + ,cl-defstruct-expansion + ,@accessor-forms + ,@alias-forms))) + +;;;; Footer + +(provide 'org-ql-macros) + +;;; org-ql-macros.el ends here diff --git a/org-ql-view-section.el b/org-ql-view-section.el deleted file mode 100644 index cff02a9..0000000 --- a/org-ql-view-section.el +++ /dev/null @@ -1,411 +0,0 @@ -;;; org-ql-view-section.el --- Magit-section-like views for Org -*- lexical-binding: t; -*- - -;; Copyright (C) 2019 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: - -;; Inspired by `magit-section'. - -;;; Code: - -;;;; Requirements - -(require 'eieio) - -(require 's) - -;;;; Macros - -(defmacro org-ql-defkeymap (name copy docstring &rest maps) - ;; Copied from `defkeymap' in elexandria.el. - "Define a new keymap variable (using `defvar'). - -NAME is a symbol, which will be the new variable's symbol. COPY -may be a keymap which will be copied, or nil, in which case the -new keymap will be sparse. DOCSTRING is the docstring for -`defvar'. - -MAPS is a sequence of alternating key-value pairs. The keys may -be a string, in which case they will be passed as arguments to -`kbd', or a raw key sequence vector. The values may be lambdas -or function symbols, as would be normally passed to -`define-key'." - (declare (indent defun)) - (let* ((map (if copy - (copy-keymap copy) - (make-sparse-keymap (prin1-to-string name))))) - (cl-loop for (key fn) on maps by #'cddr - do (progn - (when (stringp key) - (setq key (kbd key))) - (define-key map key fn))) - `(defvar ,name ',map ,docstring))) - -(defmacro org-ql-defclass (name superclasses slots &rest options-and-doc) - ;; Copied from `defclass*' in elexandria.el. - ;; MAYBE: Change instance-initform to instance-init. This would no longer set - ;; the slot to the value of the expression, but would just evaluate it. The - ;; expression could set the slot value with `setq' if necessary. - "Like `defclass', but supports instance initforms. -Each slot may have an `:instance-initform', which is evaluated in -the context of the object's slots when each instance is -initialized, similar to Python's __init__ method." - ;; TODO: Add option to set all slots' initforms (e.g. to set them all to nil). - (declare (indent defun)) - (let* ((slot-inits (-non-nil (--map (let ((name (car it)) - (initer (plist-get (cdr it) :instance-initform))) - (when initer - (list 'setq name initer))) - slots))) - (slot-names (mapcar #'car slots)) - ;; FIXME: `around-fn-name' is unused. - ;; (around-fn-name (intern (concat (symbol-name name) "-initialize"))) - (docstring (format "Inititalize instance of %s." name))) - `(progn - (defclass ,name ,superclasses ,slots ,@options-and-doc) - (when (> (length ',slot-inits) 0) - (cl-defmethod initialize-instance :after ((this ,name) &rest _) - ,docstring - (with-slots ,slot-names this - ,@slot-inits)))))) - -(cl-defmacro org-ql-defstruct (&rest args) - ;; Copied from `ts-defstruct'. - "Like `cl-defstruct', but with additional slot options. - -Additional slot options and values: - -`:accessor-init': a sexp that initializes the slot in the -accessor if the slot is nil. The symbol `struct' will be bound -to the current struct. The accessor is defined after the struct -is fully defined, so it may refer to the struct -definition (e.g. by using the `cl-struct' `pcase' macro). - -`:aliases': A list of symbols which will be aliased to the slot -accessor, prepended with the struct name (e.g. a struct `ts' with -slot `year' and alias `y' would create an alias `ts-y')." - (declare (indent defun)) - ;; FIXME: Compiler warnings about accessors defined multiple times. Not sure if we can fix this - ;; except by ignoring warnings. - (let* ((struct-name (car args)) - (struct-slots (cdr args)) - (cl-defstruct-expansion (macroexpand `(cl-defstruct ,struct-name ,@struct-slots))) - accessor-forms alias-forms) - (cl-loop for slot in struct-slots - for pos from 1 - when (listp slot) - do (-let* (((slot-name _slot-default . slot-options) slot) - ((&keys :accessor-init :aliases) slot-options) - (accessor-name (intern (concat (symbol-name struct-name) "-" (symbol-name slot-name)))) - (accessor-docstring (format "Access slot \"%s\" of `%s' struct STRUCT." - slot-name struct-name)) - (struct-pred (intern (concat (symbol-name struct-name) "-p"))) - ;; Accessor form copied from macro expansion of `cl-defstruct'. - (accessor-form `(cl-defsubst ,accessor-name (struct) - ,accessor-docstring - ;; FIXME: side-effect-free is probably not true here, but what about error-free? - ;; (declare (side-effect-free error-free)) - (or (,struct-pred struct) - (signal 'wrong-type-argument - (list ',struct-name struct))) - ,(when accessor-init - `(unless (aref struct ,pos) - (aset struct ,pos ,accessor-init))) - ;; NOTE: It's essential that this `aref' form be last - ;; so the gv-setter works in the compiler macro. - (aref struct ,pos)))) - (push accessor-form accessor-forms) - ;; Remove accessor forms from `cl-defstruct' expansion. This may be distasteful, - ;; but it would seem more distasteful to copy all of `cl-defstruct' and potentially - ;; have the implementations diverge in the future when Emacs changes (e.g. the new - ;; record type). - (cl-loop for form in-ref cl-defstruct-expansion - do (pcase form - (`(cl-defsubst ,(and accessor (guard (eq accessor accessor-name))) - . ,_) - accessor ; Silence "unused lexical variable" warning. - (setf form nil)))) - ;; Alias definitions. - (cl-loop for alias in aliases - for alias-name = (intern (concat (symbol-name struct-name) "-" (symbol-name alias))) - do (push `(defalias ',alias-name ',accessor-name) alias-forms)) - ;; TODO: Setter - ;; ,(when (plist-get slot-options :reset) - ;; `(gv-define-setter ,accessor-name (ts value) - ;; `(progn - ;; (aset ,ts ,,pos ,value) - ;; (setf (ts-unix ts) ni)))) - )) - `(progn - ,cl-defstruct-expansion - ,@accessor-forms - ,@alias-forms))) - -;;;; Variables - -(defvar org-ql-view-section-depth -1 - "Depth of current section. -Used in `org-ql-view-string'.") - -(org-ql-defkeymap org-ql-view-map nil - "Map for `org-ql-view' maps." - [tab] org-ql-view-section-toggle) - -;;;; Classes - -(org-ql-defclass org-ql-view-section () - ;; TODO: Decide/clarify whether beg/end should/can be markers. - ;; NOTE: Not using initforms for now. - ((beg :initarg :beg - :documentation "Position or marker at which section begins in buffer.") - (end :initarg :end - :documentation "Position or marker at which section ends in buffer.") - (header :initarg :header - :documention "Optional header string.") - (contents-beg :initarg :contents-beg - :documentation "Position or marker at which section's contents begins in buffer (i.e. where the header ends).") - (items :initarg :items - :documentation "List of items the section contains.") - (keymap :initarg :keymap - :instance-initform org-ql-view-map - :documentation "Keymap used inside section.") - (collapsed :initarg :collapsed - :initform nil - :documentation "Whether the section is collapsed."))) - -;;;; Structs - -(org-ql-defstruct org-ql-item - buffer marker beg category level todo priority heading tags deadline-element scheduled-element properties - (deadline-ts nil :accessor-init (when-let* ((element (org-ql-item-deadline-element struct))) - (ts-parse-org-element element))) - (scheduled-ts nil :accessor-init (when-let* ((element (org-ql-item-scheduled-element struct))) - (ts-parse-org-element element)))) - -;;;; Customization - -(defgroup org-ql-view nil - "Options for `org-ql' views." - :group 'org-ql) - -(defcustom org-ql-view-item-indent " " - "String used to indent individual items." - :type 'string) - -(defcustom org-ql-view-item-indent-per-level 4 - "Number of spaces used to indent items at each levep." - :type 'integer) - -;;;; Commands - -(defun org-ql-view-section-toggle (section) - "Toggle SECTION, or section at point." - (interactive (list (org-ql-view-section-at))) - (when section - (with-slots (collapsed) section - (if collapsed - (org-ql-section-expand section) - (org-ql-section-collapse section))))) - -(defun org-ql-section-collapse (section) - "Collapse SECTION, or section at point." - (interactive (list (org-ql-view-section-at))) - (when section - (with-slots (collapsed contents-beg end) section - (setf collapsed t) - (let ((ov (make-overlay contents-beg end))) - ;; I don't know if `evaporate' is necessary, but `magit-section' does it. - (overlay-put ov 'evaporate t) - (overlay-put ov 'invisible t))))) - -(defun org-ql-section-expand (section) - "Expand SECTION, or section at point." - (interactive (list (org-ql-view-section-at))) - (when section - (with-slots (collapsed contents-beg end) section - (setf collapsed nil) - (remove-overlays contents-beg end 'invisible t)))) - -;;;; Methods - -(cl-defmethod org-ql-view-insert ((section org-ql-view-section) &key group-by) - "Insert SECTION into current buffer." - (cl-labels ((group (items fns &key parent-header) - (setf items (-group-by (car fns) items)) - (if (cdr fns) - (--map (org-ql-view-section - :header (car it) - :items (group (cdr it) (cdr fns) :parent-header (car it))) - items) - (cond ((assoc nil items) - (append (--map (org-ql-view-section - :header (car it) - :items (cdr it)) - (butlast items)) - (cdr (assoc nil items)))) - (t (--map (org-ql-view-section - :header (car it) - :items (cdr it)) - items)))))) - (with-slots (beg end header contents-beg items keymap) section - (let* ((org-ql-view-section-depth (1+ org-ql-view-section-depth)) - (org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level - org-ql-view-section-depth) - " "))) - (when group-by - (setf items (group items group-by))) - (setf beg (point)) - (insert org-ql-view-item-indent (org-ql-view-header section)) - (put-text-property beg (point) :org-ql-view-section section) - (setf contents-beg (point)) - (let* ((org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level - (1+ org-ql-view-section-depth)) - " "))) - (dolist (item items) - (insert "\n") - (cl-typecase item - (org-ql-view-section (org-ql-view-insert item)) - (list (--each item - (insert "\n") - (org-ql-view-insert it))) - (otherwise (org-ql-view-insert item)) - ))) - (setf end (point)) - (put-text-property beg (point) 'keymap keymap))))) - -;; (cl-defmethod org-ql-view-insert ((sections list)) -;; "Insert SECTIONS into current buffer." -;; (let* ((org-ql-view-section-depth (1+ org-ql-view-section-depth))) -;; (dolist (section sections) -;; (insert "\n") -;; (org-ql-view-insert section)))) -(cl-defmethod org-ql-view-insert ((sections list)) - "Insert SECTIONS into current buffer." - (error "OOPS")) - -(cl-defmethod org-ql-view-header ((section org-ql-view-section)) - "Return header string for SECTION. -Does not include newline." - (cl-labels ((num-items (items) - (cl-loop for item in items - sum (cl-typecase item - (org-ql-view-section (num-items (oref item items))) - (list (cl-loop for section in item - sum (num-items (oref section items)))) - (otherwise 1))))) - (with-slots (header items) section - (concat (propertize (format "%s" - (or header "None")) - 'face 'magit-section-heading) - " (" (number-to-string (num-items items)) ")")))) - -(cl-defmethod org-ql-view-insert ((item org-ql-item)) - "Insert ITEM into current buffer. -Does not insert newline." - (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item) - (beg (point))) - (insert org-ql-view-item-indent) - (when todo - (insert (propertize todo 'face (org-get-todo-face todo)) " ")) - (when priority - (insert (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)) " ")) - (when heading - (insert heading " ")) - (when tags - (insert (propertize (s-join ":" tags) 'face 'org-tag-group))) - (put-text-property beg (point) :org-ql-view-section item))) - -(cl-defmethod org-ql-view-insert ((item string)) - "Insert ITEM into current buffer." - (insert item)) - -;;;; Functions - -(cl-defun org-ql-view-section-at (&optional (pos (point-at-bol))) - (get-text-property pos :org-ql-view-section)) - -(defun org-ql-item-at () - ;; FIXME: Put this function elsewhere. - "Return `org-ql-item' for entry at point." - (-let* (((_ (&plist :begin :level :raw-value :priority :tags :todo-keyword :deadline :scheduled :CATEGORY)) - (org-element-headline-parser (line-end-position)))) - (make-org-ql-item :beg begin - :category CATEGORY - :level level - :todo todo-keyword - :priority (when priority - (char-to-string priority)) - :heading raw-value - :tags tags - :deadline-element deadline - :scheduled-element scheduled))) - -(defun org-ql-view-sort-todo (items) - "Return ITEMS sorted by to-do keyword, in to-do keyword order. -Uses `org-todo-keywords', which does not include buffer-local -keywords." - (cl-flet ((keyword (string) - ;; Return keyword without parenthesized options. - (unless (string= string "|") - (if (string-match (rx (group (minimal-match (1+ anything))) - "(" (1+ anything) ")") - string) - (match-string 1 string) - string)))) - (let ((keywords (cl-loop with non-done-keywords with done-keywords - for (_type . keywords) in (reverse org-todo-keywords) - for non-done = (->> keywords - (--take-while (not (string= it "|"))) - (-map #'keyword)) - for done = (-map #'keyword - (-slice keywords - (1+ (or (--find-index (string= it "|") - keywords) - -1)))) - do (progn - (setf non-done-keywords (append non-done non-done-keywords)) - (setf done-keywords (append done done-keywords))) - finally return (append non-done-keywords done-keywords)))) - (-sort (lambda (a b) - (cond ((and (org-ql-item-todo a) - (org-ql-item-todo b)) - (< (or (cl-position (org-ql-item-todo a) keywords :test #'string=) 0) - (or (cl-position (org-ql-item-todo b) keywords :test #'string=) 0))) - ((org-ql-item-todo a) t) - ((org-ql-item-todo b) nil))) - items)))) - - -(defun org-ql-view-sort-planning (items) - "Return ITEMS sorted by planning date." - (cl-flet ((planning-ts (item) - (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)))) - (sort items (lambda (a b) - (let ((a-ts (planning-ts a)) - (b-ts (planning-ts b))) - (cond ((and a-ts b-ts) - (ts< a-ts b-ts)) - (a-ts t) - (b-ts nil))))))) - -;;;; Footer - -(provide 'org-ql-view-section) - -;;; org-ql-view-section.el ends here diff --git a/org-ql-view.el b/org-ql-view.el index d65a7a7..bd1c3f0 100644 --- a/org-ql-view.el +++ b/org-ql-view.el @@ -1,15 +1,8 @@ -;;; org-ql-view.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*- +;;; org-ql-view.el --- Views for org-ql results -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Adam Porter ;; Author: Adam Porter -;; Url: https://github.com/alphapapa/org-ql - -;;; Commentary: - -;; This library is part of the package `org-ql'; it's not a standalone -;; library. It displays strings in buffers similar to Org Agenda -;; buffers. - -;;; License: ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -24,580 +17,196 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . +;;; Commentary: + +;; Inspired by `magit-section'. + ;;; Code: ;;;; Requirements (require 'cl-lib) -(require 'map) -(require 'org) -(require 'org-element) -(require 'org-agenda) -(require 'seq) -(require 'rx) -(require 'subr-x) - -(require 'org-ql) +(require 'eieio) (require 'dash) (require 's) -(require 'org-super-agenda) -(require 'ov) -;;;; 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) +(require 'org-ql-macros) ;;;; Variables -(defvar org-ql-view-buffer-name-prefix "*Org QL View:" - "Prefix for names of `org-ql-view' buffers.") +(defvar org-ql-view-depth -1 + "Depth of current section. +Used in `org-ql-view-string'.") -(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.") +(org-ql-defkeymap org-ql-view-map nil + "Map for `org-ql-view' maps." + [tab] org-ql-view-section-toggle) -(defvar org-ql-view-map - (let ((map (copy-keymap org-agenda-mode-map))) - (define-key map "g" #'org-ql-view-refresh) - (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'.") +;;;; Classes -(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) +(org-ql-defclass org-ql-view-section () + ;; TODO: Decide/clarify whether beg/end should/can be markers. + ;; NOTE: Not using initforms for now. + ((beg :initarg :beg + :documentation "Position or marker at which section begins in buffer.") + (end :initarg :end + :documentation "Position or marker at which section ends in buffer.") + (header :initarg :header + :documention "Optional header string.") + (contents-beg :initarg :contents-beg + :documentation "Position or marker at which section's contents begins in buffer (i.e. where the header ends).") + (items :initarg :items + :documentation "List of items the section contains.") + (keymap :initarg :keymap + :instance-initform org-ql-view-map + :documentation "Keymap used inside section.") + (collapsed :initarg :collapsed + :initform nil + :documentation "Whether the section is collapsed."))) ;;;; Customization (defgroup org-ql-view nil - "Options for `org-ql-view'." + "Options for `org-ql' views." :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-item-indent " " + "String used to indent individual items." + :type 'string) -(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 the `org-ql-views' sidebar window. -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." +(defcustom org-ql-view-item-indent-per-level 2 + "Number of spaces used to indent items at each level." :type 'integer) -(defcustom org-ql-views - (list (cons "Recent entries" #'org-ql-view-recent-items) - (cons "Review (to-do keyword without timestamp in past 2 weeks)" - (list :buffers-files #'org-agenda-files - :query '(and (todo) - (not (ts :from -14))) - :title "Review" - :sort '(date priority todo) - :super-groups '((:auto-parent t)))) - (cons "Stuck Projects" (list :buffers-files #'org-agenda-files - :query '(and (todo) - (children) - (not (children (todo "NEXT")))) - :title "Stuck Projects" - :sort '(priority date) - :super-groups 'org-super-agenda-groups)) - (cons "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 "Today" (list :buffers-files #'org-agenda-files - :query '(ts-active :on today) - :title "Today" - :super-groups 'org-super-agenda-groups - :sort '(priority))) - (cons "This week" (lambda () - "Show items with an active timestamp during this calendar week." - (interactive) - (let* ((beg-of-week (ts-adjust 'day (- (ts-dow (ts-now))) (ts-now))) - (end-of-week (ts-adjust 'day (- 6 (ts-dow (ts-now))) (ts-now)))) - (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 "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-adjust 'day (- (ts-dow (ts-now))) ts)) - (end-of-week (ts-adjust 'day (- 6 (ts-dow (ts-now))) ts))) - (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)))))) - "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)))))) +(defun org-ql-view-section-toggle (section) + "Toggle SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed) section + (if collapsed + (org-ql-section-expand section) + (org-ql-section-collapse section))))) -;;;###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))) +(defun org-ql-section-collapse (section) + "Collapse SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed contents-beg end) section + (setf collapsed t) + (let ((ov (make-overlay contents-beg end))) + ;; I don't know if `evaporate' is necessary, but `magit-section' does it. + (overlay-put ov 'evaporate t) + (overlay-put ov 'invisible t))))) -;;;###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-section-expand (section) + "Expand SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed contents-beg end) section + (setf collapsed nil) + (remove-overlays contents-beg end 'invisible t)))) -(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)))) +;;;; Methods -(defun org-ql-view-refresh () - "Refresh current `org-ql-search' buffer." - (interactive) - (let ((current-line (buffer-substring-no-properties (line-beginning-position) (line-end-position))) - (old-pos (point))) - (org-ql-search org-ql-view-buffers-files - org-ql-view-query - :sort org-ql-view-sort - :narrow org-ql-view-narrow - :super-groups org-ql-view-super-groups - :title org-ql-view-title - :buffer (current-buffer)) - (goto-char (point-min)) - (or (when (search-forward current-line nil t) - (beginning-of-line)) - (goto-char old-pos)))) +(cl-defmethod org-ql-view-insert ((section org-ql-view-section) &key group-by) + "Insert SECTION into current buffer." + (cl-labels ((group (items fns) + (setf items (-group-by (car fns) items)) + (if (cdr fns) + (--map (org-ql-view-section + :header (car it) + :items (group (cdr it) (cdr fns))) + items) + (cond ((assoc nil items) + (append (--map (org-ql-view-section + :header (car it) + :items (cdr it)) + (butlast items)) + (cdr (assoc nil items)))) + (t (--map (org-ql-view-section + :header (car it) + :items (cdr it)) + items)))))) + (with-slots (beg end header contents-beg items keymap) section + (let* ((org-ql-view-depth (1+ org-ql-view-depth)) + (org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level + org-ql-view-depth) + " "))) + (when group-by + (setf items (group items group-by))) + (setf beg (point)) + (insert org-ql-view-item-indent (org-ql-view-header section)) + (put-text-property beg (point) :org-ql-view-section section) + (setf contents-beg (point)) + (let* ((org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level + (1+ org-ql-view-depth)) + " "))) + (dolist (item items) + (insert "\n") + (cl-typecase item + (org-ql-view-section (org-ql-view-insert item)) + (list (--each item + (insert "\n") + (org-ql-view-insert it))) + (otherwise (org-ql-view-insert item)) + ))) + (setf end (point)) + (put-text-property beg (point) 'keymap keymap))))) -(defun org-ql-view-save () - "Save current `org-ql-search' buffer to `org-ql-views'." - (interactive) - (let* ((name (read-string "Save view as: ")) - (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))) - (map-put org-ql-views name plist #'equal) - (customize-set-variable 'org-ql-views org-ql-views) - (customize-mark-to-save 'org-ql-views))) +;; (cl-defmethod org-ql-view-insert ((sections list)) +;; "Insert SECTIONS into current buffer." +;; (let* ((org-ql-view-depth (1+ org-ql-view-depth))) +;; (dolist (section sections) +;; (insert "\n") +;; (org-ql-view-insert section)))) +;; (cl-defmethod org-ql-view-insert ((sections list)) +;; "Insert SECTIONS into current buffer." +;; (error "OOPS")) -(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)))) +(cl-defmethod org-ql-view-header ((section org-ql-view-section)) + "Return header string for SECTION. +Does not include newline." + (cl-labels ((num-items (items) + (cl-loop for item in items + sum (cl-typecase item + (org-ql-view-section (num-items (oref item items))) + (list (cl-loop for section in item + sum (num-items (oref section items)))) + (otherwise 1))))) + (with-slots (header items) section + (concat (propertize (format "%s" + (or header "None")) + 'face 'magit-section-heading) + " (" (number-to-string (num-items items)) ")")))) + +(cl-defmethod org-ql-view-insert ((item org-ql-item)) + "Insert ITEM into current buffer. +Does not insert newline." + (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item) + (beg (point))) + (insert org-ql-view-item-indent) + (when todo + (insert (propertize todo 'face (org-get-todo-face todo)) " ")) + (when priority + (insert (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)) " ")) + (when heading + (insert heading " ")) + (when tags + (insert (propertize (s-join ":" tags) 'face 'org-tag-group))) + (put-text-property beg (point) :org-ql-view-section item))) + +(cl-defmethod org-ql-view-insert ((item string)) + "Insert ITEM into current buffer." + (insert item)) ;;;; 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 #'string<) - (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* ((buffer (cl-etypecase buffer - (string (org-ql-view--buffer buffer)) - (null (org-ql-view--buffer buffer)) - (buffer buffer)))) - (with-current-buffer buffer - (use-local-map org-ql-view-map) - ;; Prepare buffer, saving data for refreshing. - (cl-loop for symbol in (list 'org-ql-view-buffers-files 'org-ql-view-query - 'org-ql-view-sort 'org-ql-view-narrow - 'org-ql-view-super-groups 'org-ql-view-title) - do (set (make-local-variable symbol) (symbol-value symbol))) - (setf header-line-format header) - ;; Clear buffer, insert entries, etc. - (let ((inhibit-read-only t)) - (erase-buffer) - (insert string) - (pop-to-buffer (current-buffer) org-ql-view-display-buffer-action) - (org-agenda-finalize) - (goto-char (point-min)))))) - -(defun org-ql-view--header-line-format (buffers-files query &optional title) - "Return header-line-format for BUFFERS-FILES and QUERY." - (let* ((title (if title - (concat (propertize "View:" 'face 'org-agenda-structure) - title " ") - "")) - (query-formatted (format "%S" query)) - (query-formatted (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted) - 'help-echo query-formatted)) - (query-width (length query-formatted)) - (available-width (max 0 (- (window-width) - (length "In: ") - (length "Query: ") - query-width 4))) - (buffers-files-formatted (format "%S" buffers-files)) - (buffers-files-formatted (propertize (->> buffers-files-formatted - (org-ql-view--font-lock-string 'emacs-lisp-mode) - (s-truncate available-width)) - 'help-echo buffers-files-formatted))) - (concat title - (propertize "Query:" 'face 'org-agenda-structure) - query-formatted " " - (propertize "In:" 'face 'org-agenda-structure) - buffers-files-formatted))) - -(defun org-ql-view--font-lock-string (mode s) - "Return string S font-locked according to MODE." - ;; FIXME: Is this the proper way to do this? It works, but I feel like there must be a built-in way... - (with-temp-buffer - (delay-mode-hooks - (insert s) - (funcall mode) - (font-lock-ensure) - (buffer-string)))) - -(defun org-ql-view--buffer (&optional name) - "Return `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)) - (current-buffer))) - -(defun org-ql-view--format-relative-date (difference) - ;; MAYBE: Make this a `defsubst'. - "Return relative date string for DIFFERENCE. -DIFFERENCE should be an integer number of days, positive for -dates in the past, and negative for dates in the future." - (cond ((> difference 0) - (format "%sd ago" difference)) - ((< difference 0) - (format "in %sd" (* -1 difference))) - (t "today"))) - -;;;; Faces/properties - -(defun org-ql-view--format-element (element) - ;; This essentially needs to do what `org-agenda-format-item' does, - ;; which is a lot. We are a long way from that, but it's a start. - "Return ELEMENT as a string with text-properties set by its property list. -Its property list should be the second item in the list, as -returned by `org-element-parse-buffer'. If ELEMENT is nil, -return an empty string." - (if (not element) - "" - (let* ((properties (cadr element)) - ;; Remove the :parent property, which so bloats the size of - ;; the properties list that it makes it essentially - ;; impossible to debug, because Emacs takes approximately - ;; forever to show it in the minibuffer or with - ;; `describe-text-properties'. FIXME: Shouldn't be necessary - ;; anymore since we're not parsing the whole buffer. - - ;; Also, remove ":" from key symbols. FIXME: It would be - ;; better to avoid this somehow. At least, we should use a - ;; function to convert plists to alists, if possible. - (properties (cl-loop for (key val) on properties by #'cddr - for symbol = (intern (cl-subseq (symbol-name key) 1)) - unless (member symbol '(parent)) - append (list symbol val))) - ;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is - ;; hidden by doing it through --add-faces (which calls --add-scheduled-face and - ;; --add-deadline-face), and doing it in this form that gets the title hides it even more. - ;; Adding the relative due date property should probably be done explicitly and separately - ;; (which would also make it easier to do it independently of faces, etc). - (title (--> (org-ql-view--add-faces element) - (org-element-property :raw-value it) - (org-link-display-format it))) - (todo-keyword (-some--> (org-element-property :todo-keyword element) - (org-ql-view--add-todo-face it))) - ;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc. - (tag-list (if org-use-tag-inheritance - ;; FIXME: Note that tag inheritance cannot be used here unless markers are - ;; added, otherwise we can't go to the item's buffer to look for inherited - ;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I - ;; forget...) - (if-let ((marker (or (org-element-property :org-hd-marker element) - (org-element-property :org-marker element)))) - (with-current-buffer (marker-buffer marker) - ;; I wish `org-get-tags' used the correct buffer automatically. - (org-get-tags marker (not org-use-tag-inheritance))) - ;; No marker found - (warn "No marker found for item: %s" title) - (org-element-property :tags element)) - (org-element-property :tags element))) - (tag-string (when tag-list - (--> tag-list - (s-join ":" it) - (s-wrap it ":") - (org-add-props it nil 'face 'org-tag)))) - ;; (category (org-element-property :category element)) - (priority-string (-some->> (org-element-property :priority element) - (char-to-string) - (format "[#%s]") - (org-ql-view--add-priority-face))) - (habit-property (org-with-point-at (org-element-property :begin element) - (when (org-is-habit-p) - (org-habit-parse-todo)))) - (due-string (pcase (org-element-property :relative-due-date element) - ('nil "") - (string (format " %s " (org-add-props string nil 'face 'org-ql-view-due-date))))) - (string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string))))) - (remove-list-of-text-properties 0 (length string) '(line-prefix) string) - ;; Add all the necessary properties and faces to the whole string - (--> string - ;; FIXME: Use proper prefix - (concat " " it) - (org-add-props it properties - '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 TODO face added." - (when-let ((face (org-get-todo-face keyword))) - (org-add-props keyword nil 'face face))) +(cl-defun org-ql-view-section-at (&optional (pos (point-at-bol))) + "Return section at POS or point." + (get-text-property pos :org-ql-view-section)) ;;;; Footer diff --git a/test-org-ql-view-section.el b/test-org-ql-view-section.el index 80c927a..90eb3c0 100644 --- a/test-org-ql-view-section.el +++ b/test-org-ql-view-section.el @@ -1,3 +1,6 @@ +(require 'org-ql-item) +(require 'org-ql-view) + (let* ((buffer (get-buffer-create "test-org-ql-view-section")) (sub-section1 (org-ql-view-section :items (list (make-org-ql-item :level 1 From fdbff54ebdf4c360c9efbe08e67c821b88a2ed23 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sat, 7 Sep 2019 18:48:33 -0500 Subject: [PATCH 4/7] WIP --- org-ql-view.el | 10 ++++++++-- test-org-ql-view-section.el | 27 ++++++++++++++++++++++++--- 2 files changed, 32 insertions(+), 5 deletions(-) diff --git a/org-ql-view.el b/org-ql-view.el index bd1c3f0..3491b96 100644 --- a/org-ql-view.el +++ b/org-ql-view.el @@ -43,6 +43,12 @@ Used in `org-ql-view-string'.") "Map for `org-ql-view' maps." [tab] org-ql-view-section-toggle) +;;;; Faces + +(defface org-ql-view-heading + `((t (:height 1.2 :weight bold))) + "Face for headings in `org-ql-view' buffers.") + ;;;; Classes (org-ql-defclass org-ql-view-section () @@ -75,7 +81,7 @@ Used in `org-ql-view-string'.") "String used to indent individual items." :type 'string) -(defcustom org-ql-view-item-indent-per-level 2 +(defcustom org-ql-view-item-indent-per-level 3 "Number of spaces used to indent items at each level." :type 'integer) @@ -179,7 +185,7 @@ Does not include newline." (with-slots (header items) section (concat (propertize (format "%s" (or header "None")) - 'face 'magit-section-heading) + 'face 'org-ql-view-heading) " (" (number-to-string (num-items items)) ")")))) (cl-defmethod org-ql-view-insert ((item org-ql-item)) diff --git a/test-org-ql-view-section.el b/test-org-ql-view-section.el index 90eb3c0..1678383 100644 --- a/test-org-ql-view-section.el +++ b/test-org-ql-view-section.el @@ -115,7 +115,8 @@ '(todo) :action #'org-ql-item-at) (-sort (-on #'string< #'org-ql-item-priority)) - (org-ql-view-sort-planning))) + (org-ql-view-sort-planning) + (org-ql-view-sort-todo))) (top-section (org-ql-view-section :header "To-Do by Planning Date" :items items)) @@ -129,8 +130,7 @@ (ts-format "%B %Y" it))) (lambda (item) (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) - (ts-format "%d %B" it))) - 'org-ql-item-todo + (ts-format "%d %A" it))) )) (pop-to-buffer buffer))) (let* ((buffer (get-buffer-create "test-org-ql-view-section")) @@ -151,6 +151,27 @@ (lambda (item) (awhen (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item)) (ts-format "%B %Y" it))) + 'org-ql-item-priority + + )) + (pop-to-buffer buffer))) + +(let* ((buffer (get-buffer-create "test-org-ql-view-section")) + (items (->> (org-ql-select "~/src/emacs/org-ql/tests/data.org" + '(todo) + :action #'org-ql-item-at) + (-sort (-on #'string< #'org-ql-item-priority)) + (org-ql-view-sort-planning))) + (top-section (org-ql-view-section + :header "To-Do by Planning Date" + :items items)) + (inhibit-read-only t)) + (with-current-buffer buffer + (read-only-mode 1) + (erase-buffer) + (org-ql-view-insert top-section + :group-by (list 'org-ql-item-priority + 'org-ql-item-todo )) (pop-to-buffer buffer))) From 17e215461d00fe5a1e78d155a714fb3c9b2ace3e Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Tue, 17 Sep 2019 18:47:40 -0500 Subject: [PATCH 5/7] Notes: Add idea --- notes.org | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/notes.org b/notes.org index 43569a2..e209153 100644 --- a/notes.org +++ b/notes.org @@ -286,6 +286,10 @@ Another idea for it is to simply store the element from =org-element-headline-pa The code that powers the customization UI. Has collapsible and customizable widgets. Might be perfect. Might even enable editing items in the list, with functions to make the changes in the source buffers. +*** TODO Experiment with =hierarchy= + +[[https://github.com/DamienCassou/hierarchy][hierarchy.el]] might be very helpful for implementing a hierarchy UI. Maybe the =parentfn= could be used to create sections easily. + *** Code idea Inserting items into a view could look something like this: From 69381dc0809d40f0e6bc44236f2cff53feabcf76 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Wed, 2 Oct 2019 16:53:45 -0500 Subject: [PATCH 6/7] WIP: Rename and restore Rename org-ql-view.el back to org-ql-view-section.el, and bring back org-ql-view.el from before rebasing on master. --- org-ql-view-section.el | 221 +++++++++++++ org-ql-view.el | 713 +++++++++++++++++++++++++++++++---------- 2 files changed, 770 insertions(+), 164 deletions(-) create mode 100644 org-ql-view-section.el diff --git a/org-ql-view-section.el b/org-ql-view-section.el new file mode 100644 index 0000000..3491b96 --- /dev/null +++ b/org-ql-view-section.el @@ -0,0 +1,221 @@ +;;; org-ql-view.el --- Views for org-ql results -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Adam Porter + +;; Author: Adam Porter + +;; 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: + +;; Inspired by `magit-section'. + +;;; Code: + +;;;; Requirements + +(require 'cl-lib) +(require 'eieio) + +(require 'dash) +(require 's) + +(require 'org-ql-macros) + +;;;; Variables + +(defvar org-ql-view-depth -1 + "Depth of current section. +Used in `org-ql-view-string'.") + +(org-ql-defkeymap org-ql-view-map nil + "Map for `org-ql-view' maps." + [tab] org-ql-view-section-toggle) + +;;;; Faces + +(defface org-ql-view-heading + `((t (:height 1.2 :weight bold))) + "Face for headings in `org-ql-view' buffers.") + +;;;; Classes + +(org-ql-defclass org-ql-view-section () + ;; TODO: Decide/clarify whether beg/end should/can be markers. + ;; NOTE: Not using initforms for now. + ((beg :initarg :beg + :documentation "Position or marker at which section begins in buffer.") + (end :initarg :end + :documentation "Position or marker at which section ends in buffer.") + (header :initarg :header + :documention "Optional header string.") + (contents-beg :initarg :contents-beg + :documentation "Position or marker at which section's contents begins in buffer (i.e. where the header ends).") + (items :initarg :items + :documentation "List of items the section contains.") + (keymap :initarg :keymap + :instance-initform org-ql-view-map + :documentation "Keymap used inside section.") + (collapsed :initarg :collapsed + :initform nil + :documentation "Whether the section is collapsed."))) + +;;;; Customization + +(defgroup org-ql-view nil + "Options for `org-ql' views." + :group 'org-ql) + +(defcustom org-ql-view-item-indent " " + "String used to indent individual items." + :type 'string) + +(defcustom org-ql-view-item-indent-per-level 3 + "Number of spaces used to indent items at each level." + :type 'integer) + +;;;; Commands + +(defun org-ql-view-section-toggle (section) + "Toggle SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed) section + (if collapsed + (org-ql-section-expand section) + (org-ql-section-collapse section))))) + +(defun org-ql-section-collapse (section) + "Collapse SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed contents-beg end) section + (setf collapsed t) + (let ((ov (make-overlay contents-beg end))) + ;; I don't know if `evaporate' is necessary, but `magit-section' does it. + (overlay-put ov 'evaporate t) + (overlay-put ov 'invisible t))))) + +(defun org-ql-section-expand (section) + "Expand SECTION, or section at point." + (interactive (list (org-ql-view-section-at))) + (when section + (with-slots (collapsed contents-beg end) section + (setf collapsed nil) + (remove-overlays contents-beg end 'invisible t)))) + +;;;; Methods + +(cl-defmethod org-ql-view-insert ((section org-ql-view-section) &key group-by) + "Insert SECTION into current buffer." + (cl-labels ((group (items fns) + (setf items (-group-by (car fns) items)) + (if (cdr fns) + (--map (org-ql-view-section + :header (car it) + :items (group (cdr it) (cdr fns))) + items) + (cond ((assoc nil items) + (append (--map (org-ql-view-section + :header (car it) + :items (cdr it)) + (butlast items)) + (cdr (assoc nil items)))) + (t (--map (org-ql-view-section + :header (car it) + :items (cdr it)) + items)))))) + (with-slots (beg end header contents-beg items keymap) section + (let* ((org-ql-view-depth (1+ org-ql-view-depth)) + (org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level + org-ql-view-depth) + " "))) + (when group-by + (setf items (group items group-by))) + (setf beg (point)) + (insert org-ql-view-item-indent (org-ql-view-header section)) + (put-text-property beg (point) :org-ql-view-section section) + (setf contents-beg (point)) + (let* ((org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level + (1+ org-ql-view-depth)) + " "))) + (dolist (item items) + (insert "\n") + (cl-typecase item + (org-ql-view-section (org-ql-view-insert item)) + (list (--each item + (insert "\n") + (org-ql-view-insert it))) + (otherwise (org-ql-view-insert item)) + ))) + (setf end (point)) + (put-text-property beg (point) 'keymap keymap))))) + +;; (cl-defmethod org-ql-view-insert ((sections list)) +;; "Insert SECTIONS into current buffer." +;; (let* ((org-ql-view-depth (1+ org-ql-view-depth))) +;; (dolist (section sections) +;; (insert "\n") +;; (org-ql-view-insert section)))) +;; (cl-defmethod org-ql-view-insert ((sections list)) +;; "Insert SECTIONS into current buffer." +;; (error "OOPS")) + +(cl-defmethod org-ql-view-header ((section org-ql-view-section)) + "Return header string for SECTION. +Does not include newline." + (cl-labels ((num-items (items) + (cl-loop for item in items + sum (cl-typecase item + (org-ql-view-section (num-items (oref item items))) + (list (cl-loop for section in item + sum (num-items (oref section items)))) + (otherwise 1))))) + (with-slots (header items) section + (concat (propertize (format "%s" + (or header "None")) + 'face 'org-ql-view-heading) + " (" (number-to-string (num-items items)) ")")))) + +(cl-defmethod org-ql-view-insert ((item org-ql-item)) + "Insert ITEM into current buffer. +Does not insert newline." + (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item) + (beg (point))) + (insert org-ql-view-item-indent) + (when todo + (insert (propertize todo 'face (org-get-todo-face todo)) " ")) + (when priority + (insert (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)) " ")) + (when heading + (insert heading " ")) + (when tags + (insert (propertize (s-join ":" tags) 'face 'org-tag-group))) + (put-text-property beg (point) :org-ql-view-section item))) + +(cl-defmethod org-ql-view-insert ((item string)) + "Insert ITEM into current buffer." + (insert item)) + +;;;; Functions + +(cl-defun org-ql-view-section-at (&optional (pos (point-at-bol))) + "Return section at POS or point." + (get-text-property pos :org-ql-view-section)) + +;;;; Footer + +(provide 'org-ql-view) + +;;; org-ql-view.el ends here diff --git a/org-ql-view.el b/org-ql-view.el index 3491b96..d65a7a7 100644 --- a/org-ql-view.el +++ b/org-ql-view.el @@ -1,8 +1,15 @@ -;;; org-ql-view.el --- Views for org-ql results -*- lexical-binding: t; -*- - -;; Copyright (C) 2019 Adam Porter +;;; org-ql-view.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*- ;; Author: Adam Porter +;; Url: https://github.com/alphapapa/org-ql + +;;; Commentary: + +;; This library is part of the package `org-ql'; it's not a standalone +;; library. It displays strings in buffers similar to Org Agenda +;; buffers. + +;;; License: ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -17,202 +24,580 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . -;;; Commentary: - -;; Inspired by `magit-section'. - ;;; Code: ;;;; Requirements (require 'cl-lib) -(require 'eieio) +(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 'org-ql-macros) +;;;; Compatibility -;;;; Variables - -(defvar org-ql-view-depth -1 - "Depth of current section. -Used in `org-ql-view-string'.") - -(org-ql-defkeymap org-ql-view-map nil - "Map for `org-ql-view' maps." - [tab] org-ql-view-section-toggle) +(when (version< org-version "9.2") + (defalias 'org-get-tags #'org-get-tags-at)) ;;;; Faces -(defface org-ql-view-heading - `((t (:height 1.2 :weight bold))) - "Face for headings in `org-ql-view' buffers.") +(defface org-ql-view-due-date + '((t (:slant italic :weight bold))) + "Face for due dates in `org-ql-view' views." + :group 'org-ql) -;;;; Classes +;;;; Variables -(org-ql-defclass org-ql-view-section () - ;; TODO: Decide/clarify whether beg/end should/can be markers. - ;; NOTE: Not using initforms for now. - ((beg :initarg :beg - :documentation "Position or marker at which section begins in buffer.") - (end :initarg :end - :documentation "Position or marker at which section ends in buffer.") - (header :initarg :header - :documention "Optional header string.") - (contents-beg :initarg :contents-beg - :documentation "Position or marker at which section's contents begins in buffer (i.e. where the header ends).") - (items :initarg :items - :documentation "List of items the section contains.") - (keymap :initarg :keymap - :instance-initform org-ql-view-map - :documentation "Keymap used inside section.") - (collapsed :initarg :collapsed - :initform nil - :documentation "Whether the section is collapsed."))) +(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 (copy-keymap org-agenda-mode-map))) + (define-key map "g" #'org-ql-view-refresh) + (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' views." + "Options for `org-ql-view'." :group 'org-ql) -(defcustom org-ql-view-item-indent " " - "String used to indent individual items." - :type 'string) +(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-item-indent-per-level 3 - "Number of spaces used to indent items at each level." +(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 the `org-ql-views' sidebar window. +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-views + (list (cons "Recent entries" #'org-ql-view-recent-items) + (cons "Review (to-do keyword without timestamp in past 2 weeks)" + (list :buffers-files #'org-agenda-files + :query '(and (todo) + (not (ts :from -14))) + :title "Review" + :sort '(date priority todo) + :super-groups '((:auto-parent t)))) + (cons "Stuck Projects" (list :buffers-files #'org-agenda-files + :query '(and (todo) + (children) + (not (children (todo "NEXT")))) + :title "Stuck Projects" + :sort '(priority date) + :super-groups 'org-super-agenda-groups)) + (cons "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 "Today" (list :buffers-files #'org-agenda-files + :query '(ts-active :on today) + :title "Today" + :super-groups 'org-super-agenda-groups + :sort '(priority))) + (cons "This week" (lambda () + "Show items with an active timestamp during this calendar week." + (interactive) + (let* ((beg-of-week (ts-adjust 'day (- (ts-dow (ts-now))) (ts-now))) + (end-of-week (ts-adjust 'day (- 6 (ts-dow (ts-now))) (ts-now)))) + (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 "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-adjust 'day (- (ts-dow (ts-now))) ts)) + (end-of-week (ts-adjust 'day (- 6 (ts-dow (ts-now))) ts))) + (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)))))) + "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 -(defun org-ql-view-section-toggle (section) - "Toggle SECTION, or section at point." - (interactive (list (org-ql-view-section-at))) - (when section - (with-slots (collapsed) section - (if collapsed - (org-ql-section-expand section) - (org-ql-section-collapse section))))) +;;;###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)))))) -(defun org-ql-section-collapse (section) - "Collapse SECTION, or section at point." - (interactive (list (org-ql-view-section-at))) - (when section - (with-slots (collapsed contents-beg end) section - (setf collapsed t) - (let ((ov (make-overlay contents-beg end))) - ;; I don't know if `evaporate' is necessary, but `magit-section' does it. - (overlay-put ov 'evaporate t) - (overlay-put ov 'invisible t))))) +;;;###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))) -(defun org-ql-section-expand (section) - "Expand SECTION, or section at point." - (interactive (list (org-ql-view-section-at))) - (when section - (with-slots (collapsed contents-beg end) section - (setf collapsed nil) - (remove-overlays contents-beg end 'invisible t)))) +;;;###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)))))))) -;;;; Methods +(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)))) -(cl-defmethod org-ql-view-insert ((section org-ql-view-section) &key group-by) - "Insert SECTION into current buffer." - (cl-labels ((group (items fns) - (setf items (-group-by (car fns) items)) - (if (cdr fns) - (--map (org-ql-view-section - :header (car it) - :items (group (cdr it) (cdr fns))) - items) - (cond ((assoc nil items) - (append (--map (org-ql-view-section - :header (car it) - :items (cdr it)) - (butlast items)) - (cdr (assoc nil items)))) - (t (--map (org-ql-view-section - :header (car it) - :items (cdr it)) - items)))))) - (with-slots (beg end header contents-beg items keymap) section - (let* ((org-ql-view-depth (1+ org-ql-view-depth)) - (org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level - org-ql-view-depth) - " "))) - (when group-by - (setf items (group items group-by))) - (setf beg (point)) - (insert org-ql-view-item-indent (org-ql-view-header section)) - (put-text-property beg (point) :org-ql-view-section section) - (setf contents-beg (point)) - (let* ((org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level - (1+ org-ql-view-depth)) - " "))) - (dolist (item items) - (insert "\n") - (cl-typecase item - (org-ql-view-section (org-ql-view-insert item)) - (list (--each item - (insert "\n") - (org-ql-view-insert it))) - (otherwise (org-ql-view-insert item)) - ))) - (setf end (point)) - (put-text-property beg (point) 'keymap keymap))))) +(defun org-ql-view-refresh () + "Refresh current `org-ql-search' buffer." + (interactive) + (let ((current-line (buffer-substring-no-properties (line-beginning-position) (line-end-position))) + (old-pos (point))) + (org-ql-search org-ql-view-buffers-files + org-ql-view-query + :sort org-ql-view-sort + :narrow org-ql-view-narrow + :super-groups org-ql-view-super-groups + :title org-ql-view-title + :buffer (current-buffer)) + (goto-char (point-min)) + (or (when (search-forward current-line nil t) + (beginning-of-line)) + (goto-char old-pos)))) -;; (cl-defmethod org-ql-view-insert ((sections list)) -;; "Insert SECTIONS into current buffer." -;; (let* ((org-ql-view-depth (1+ org-ql-view-depth))) -;; (dolist (section sections) -;; (insert "\n") -;; (org-ql-view-insert section)))) -;; (cl-defmethod org-ql-view-insert ((sections list)) -;; "Insert SECTIONS into current buffer." -;; (error "OOPS")) +(defun org-ql-view-save () + "Save current `org-ql-search' buffer to `org-ql-views'." + (interactive) + (let* ((name (read-string "Save view as: ")) + (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))) + (map-put org-ql-views name plist #'equal) + (customize-set-variable 'org-ql-views org-ql-views) + (customize-mark-to-save 'org-ql-views))) -(cl-defmethod org-ql-view-header ((section org-ql-view-section)) - "Return header string for SECTION. -Does not include newline." - (cl-labels ((num-items (items) - (cl-loop for item in items - sum (cl-typecase item - (org-ql-view-section (num-items (oref item items))) - (list (cl-loop for section in item - sum (num-items (oref section items)))) - (otherwise 1))))) - (with-slots (header items) section - (concat (propertize (format "%s" - (or header "None")) - 'face 'org-ql-view-heading) - " (" (number-to-string (num-items items)) ")")))) - -(cl-defmethod org-ql-view-insert ((item org-ql-item)) - "Insert ITEM into current buffer. -Does not insert newline." - (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item) - (beg (point))) - (insert org-ql-view-item-indent) - (when todo - (insert (propertize todo 'face (org-get-todo-face todo)) " ")) - (when priority - (insert (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)) " ")) - (when heading - (insert heading " ")) - (when tags - (insert (propertize (s-join ":" tags) 'face 'org-tag-group))) - (put-text-property beg (point) :org-ql-view-section item))) - -(cl-defmethod org-ql-view-insert ((item string)) - "Insert ITEM into current buffer." - (insert item)) +(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 -(cl-defun org-ql-view-section-at (&optional (pos (point-at-bol))) - "Return section at POS or point." - (get-text-property pos :org-ql-view-section)) +(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 #'string<) + (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* ((buffer (cl-etypecase buffer + (string (org-ql-view--buffer buffer)) + (null (org-ql-view--buffer buffer)) + (buffer buffer)))) + (with-current-buffer buffer + (use-local-map org-ql-view-map) + ;; Prepare buffer, saving data for refreshing. + (cl-loop for symbol in (list 'org-ql-view-buffers-files 'org-ql-view-query + 'org-ql-view-sort 'org-ql-view-narrow + 'org-ql-view-super-groups 'org-ql-view-title) + do (set (make-local-variable symbol) (symbol-value symbol))) + (setf header-line-format header) + ;; Clear buffer, insert entries, etc. + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (pop-to-buffer (current-buffer) org-ql-view-display-buffer-action) + (org-agenda-finalize) + (goto-char (point-min)))))) + +(defun org-ql-view--header-line-format (buffers-files query &optional title) + "Return header-line-format for BUFFERS-FILES and QUERY." + (let* ((title (if title + (concat (propertize "View:" 'face 'org-agenda-structure) + title " ") + "")) + (query-formatted (format "%S" query)) + (query-formatted (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted) + 'help-echo query-formatted)) + (query-width (length query-formatted)) + (available-width (max 0 (- (window-width) + (length "In: ") + (length "Query: ") + query-width 4))) + (buffers-files-formatted (format "%S" buffers-files)) + (buffers-files-formatted (propertize (->> buffers-files-formatted + (org-ql-view--font-lock-string 'emacs-lisp-mode) + (s-truncate available-width)) + 'help-echo buffers-files-formatted))) + (concat title + (propertize "Query:" 'face 'org-agenda-structure) + query-formatted " " + (propertize "In:" 'face 'org-agenda-structure) + buffers-files-formatted))) + +(defun org-ql-view--font-lock-string (mode s) + "Return string S font-locked according to MODE." + ;; FIXME: Is this the proper way to do this? It works, but I feel like there must be a built-in way... + (with-temp-buffer + (delay-mode-hooks + (insert s) + (funcall mode) + (font-lock-ensure) + (buffer-string)))) + +(defun org-ql-view--buffer (&optional name) + "Return `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)) + (current-buffer))) + +(defun org-ql-view--format-relative-date (difference) + ;; MAYBE: Make this a `defsubst'. + "Return relative date string for DIFFERENCE. +DIFFERENCE should be an integer number of days, positive for +dates in the past, and negative for dates in the future." + (cond ((> difference 0) + (format "%sd ago" difference)) + ((< difference 0) + (format "in %sd" (* -1 difference))) + (t "today"))) + +;;;; Faces/properties + +(defun org-ql-view--format-element (element) + ;; This essentially needs to do what `org-agenda-format-item' does, + ;; which is a lot. We are a long way from that, but it's a start. + "Return ELEMENT as a string with text-properties set by its property list. +Its property list should be the second item in the list, as +returned by `org-element-parse-buffer'. If ELEMENT is nil, +return an empty string." + (if (not element) + "" + (let* ((properties (cadr element)) + ;; Remove the :parent property, which so bloats the size of + ;; the properties list that it makes it essentially + ;; impossible to debug, because Emacs takes approximately + ;; forever to show it in the minibuffer or with + ;; `describe-text-properties'. FIXME: Shouldn't be necessary + ;; anymore since we're not parsing the whole buffer. + + ;; Also, remove ":" from key symbols. FIXME: It would be + ;; better to avoid this somehow. At least, we should use a + ;; function to convert plists to alists, if possible. + (properties (cl-loop for (key val) on properties by #'cddr + for symbol = (intern (cl-subseq (symbol-name key) 1)) + unless (member symbol '(parent)) + append (list symbol val))) + ;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is + ;; hidden by doing it through --add-faces (which calls --add-scheduled-face and + ;; --add-deadline-face), and doing it in this form that gets the title hides it even more. + ;; Adding the relative due date property should probably be done explicitly and separately + ;; (which would also make it easier to do it independently of faces, etc). + (title (--> (org-ql-view--add-faces element) + (org-element-property :raw-value it) + (org-link-display-format it))) + (todo-keyword (-some--> (org-element-property :todo-keyword element) + (org-ql-view--add-todo-face it))) + ;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc. + (tag-list (if org-use-tag-inheritance + ;; FIXME: Note that tag inheritance cannot be used here unless markers are + ;; added, otherwise we can't go to the item's buffer to look for inherited + ;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I + ;; forget...) + (if-let ((marker (or (org-element-property :org-hd-marker element) + (org-element-property :org-marker element)))) + (with-current-buffer (marker-buffer marker) + ;; I wish `org-get-tags' used the correct buffer automatically. + (org-get-tags marker (not org-use-tag-inheritance))) + ;; No marker found + (warn "No marker found for item: %s" title) + (org-element-property :tags element)) + (org-element-property :tags element))) + (tag-string (when tag-list + (--> tag-list + (s-join ":" it) + (s-wrap it ":") + (org-add-props it nil 'face 'org-tag)))) + ;; (category (org-element-property :category element)) + (priority-string (-some->> (org-element-property :priority element) + (char-to-string) + (format "[#%s]") + (org-ql-view--add-priority-face))) + (habit-property (org-with-point-at (org-element-property :begin element) + (when (org-is-habit-p) + (org-habit-parse-todo)))) + (due-string (pcase (org-element-property :relative-due-date element) + ('nil "") + (string (format " %s " (org-add-props string nil 'face 'org-ql-view-due-date))))) + (string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string))))) + (remove-list-of-text-properties 0 (length string) '(line-prefix) string) + ;; Add all the necessary properties and faces to the whole string + (--> string + ;; FIXME: Use proper prefix + (concat " " it) + (org-add-props it properties + '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 TODO face added." + (when-let ((face (org-get-todo-face keyword))) + (org-add-props keyword nil 'face face))) ;;;; Footer From ee524c192709490e06fdaf98ba109455e89e1c2b Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Wed, 9 Oct 2019 19:18:46 -0500 Subject: [PATCH 7/7] Notes: Add about direx-el --- notes.org | 2 ++ 1 file changed, 2 insertions(+) diff --git a/notes.org b/notes.org index e209153..580cbde 100644 --- a/notes.org +++ b/notes.org @@ -282,6 +282,8 @@ One of the things in that branch is =org-ql-item=, which is a struct used to car Another idea for it is to simply store the element from =org-element-headline-parser= in one of its slots, and populate all of the other slots lazily, like =ts=. It already does that for a couple of slots, but I think it makes sense to do it for all of them, to reduce the overhead of making the struct for every query result. +[2019-10-09 Wed 19:17] (re?)Discovered [[https://github.com/m2ym/direx-el][GitHub - m2ym/direx-el: Directory Explorer for GNU Emacs]], which uses EIEIO to implement expandable sections that look much like the ones in Magit, with depth-based indentation like in =magit-todos=. + *** TODO Experiment with =widget= The code that powers the customization UI. Has collapsible and customizable widgets. Might be perfect. Might even enable editing items in the list, with functions to make the changes in the source buffers.