From 5a4422079a53db3cff307eba51b0a489a71ce209 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sat, 7 Sep 2019 18:02:21 -0500 Subject: [PATCH] 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