mirror of
https://github.com/pestctrl/emacs-config.git
synced 2026-02-16 16:24:18 +00:00
278 lines
14 KiB
EmacsLisp
278 lines
14 KiB
EmacsLisp
;;; org-ql-custom-stuck-projects.el --- -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2019 Benson Chu
|
|
|
|
;; Author: Benson Chu <bensonchu457@gmail.com>
|
|
;; Created: [2019-12-17 19:56]
|
|
|
|
;; This file is not part of GNU Emacs
|
|
|
|
;; 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 <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
(require 'org)
|
|
(require 'org-agenda)
|
|
(require 'org-project)
|
|
(require 'org-ql)
|
|
(require 'org-ql-search)
|
|
|
|
(defun my/top-level ()
|
|
(save-excursion
|
|
(catch 'break
|
|
(while (org-up-heading-safe)
|
|
(when (org-get-todo-state)
|
|
(throw 'break nil)))
|
|
t)))
|
|
|
|
(defun my/testing-get-displayables ()
|
|
(interactive)
|
|
(my/get-project-stuck-displayables
|
|
(org-ql--add-markers
|
|
(org-element-headline-parser
|
|
(point)))))
|
|
|
|
(defconst my/is-project-short-circuit
|
|
'((not (tags "short"))
|
|
(todo "TODO" "TASK" "ONE" "META" "META1" "EMPTY" "SEQ")
|
|
(my/top-level)))
|
|
|
|
(defun my/get-project-stuck-displayables (element)
|
|
(let ((marker (org-element-property :org-marker element)))
|
|
(with-current-buffer (marker-buffer marker)
|
|
(goto-char marker)
|
|
(let* ((state (org-get-todo-state)))
|
|
(if (member state '("EMPTY"))
|
|
(list element)
|
|
(cons element
|
|
(let (display nothing)
|
|
(olc/todo-children
|
|
(let ((type (opr/get-type)))
|
|
(pcase type
|
|
('project
|
|
(when (eq 'stuck (opr/type-of-project))
|
|
(let ((res (-> (point)
|
|
(org-element-headline-parser)
|
|
(org-ql--add-markers)
|
|
(my/get-project-stuck-displayables)
|
|
(reverse))))
|
|
(setf display (append res display)))))
|
|
('task
|
|
(cond
|
|
((eq 'stuck (opr/type-of-task))
|
|
(push (org-ql--add-markers (org-element-headline-parser (point)))
|
|
display))
|
|
((member (org-get-todo-state) '("FUTURE" "BACKLOG"))
|
|
(push (org-ql--add-markers (org-element-headline-parser (point)))
|
|
nothing)))))))
|
|
(reverse (or display nothing)))))))))
|
|
|
|
(defun my/org-ql-stuck-projects (tag)
|
|
(let (narrow-p old-beg old-end)
|
|
(when-let* ((from (pcase org-agenda-overriding-restriction
|
|
('nil (org-agenda-files nil 'ifmode))
|
|
('file (get 'org-agenda-files 'org-restrict))
|
|
('subtree (prog1 org-agenda-restrict
|
|
(with-current-buffer org-agenda-restrict
|
|
;; Narrow the buffer; remember to widen it later.
|
|
(setf old-beg (point-min) old-end (point-max)
|
|
narrow-p t)
|
|
(narrow-to-region org-agenda-restrict-begin org-agenda-restrict-end)))))))
|
|
(let* ((org-todo-keywords-1 '("EMPTY" "ONE" "META" "META1" "TODO" "TASK" "SEQ"))
|
|
(items (mapcan #'my/get-project-stuck-displayables
|
|
(org-ql-select from
|
|
`(and ,@(when (and tag
|
|
(not (zerop (length tag))))
|
|
`((tags ,tag)))
|
|
(odl/part-of-current-level-p)
|
|
,@my/is-project-short-circuit
|
|
(or (eq 'stuck (opr/type-of-task))
|
|
(eq 'stuck (opr/type-of-project))))
|
|
:action 'element-with-markers
|
|
:narrow narrow-p
|
|
:sort 'todo))))
|
|
(when narrow-p
|
|
;; Restore buffer's previous restrictions.
|
|
(with-current-buffer from
|
|
(narrow-to-region old-beg old-end)))
|
|
(org-agenda-prepare)
|
|
;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than
|
|
;; I'm using. Should probably declare it as a minimum Org version after upgrading.
|
|
;; (org-agenda--insert-overriding-header (or org-ql-block-header (org-ql-agenda--header-line-format from query)))
|
|
(insert (org-add-props org-ql-block-header
|
|
nil 'face 'org-agenda-structure 'org-agenda-type 'search) "\n")
|
|
;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda,
|
|
;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing.
|
|
;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work.
|
|
(let ((org-agenda-sorting-strategy-selected '(category-keep) ))
|
|
(->> items
|
|
(-map #'org-ql-view--format-element)
|
|
org-agenda-finalize-entries
|
|
insert))
|
|
(insert "\n")))))
|
|
|
|
;; (defun my/org-ql-stuck-projects (tag)
|
|
;; (let* ((from (org-agenda-files nil 'ifmode))
|
|
;; (org-todo-keywords-1 '("EMPTY" "ONE" "META" "META1" "TODO"))
|
|
;; (items (org-ql-select org-agenda-files
|
|
;; `(and ,@(when (and tag
|
|
;; (not (zerop (length tag))))
|
|
;; '((tags ,tag)))
|
|
;; (not (property "DELAYED"))
|
|
;; (or (descendants (eq 'stuck (opr/type-of-task)))
|
|
;; (eq 'stuck (opr/type-of-task))))
|
|
;; :action 'element-with-markers
|
|
;; :sort 'todo)))
|
|
;; (org-agenda-prepare)
|
|
;; ;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than
|
|
;; ;; I'm using. Should probably declare it as a minimum Org version after upgrading.
|
|
;; ;; (org-agenda--insert-overriding-header (or org-ql-block-header (org-ql-agenda--header-line-format from query)))
|
|
;; (insert (org-add-props org-ql-block-header
|
|
;; nil 'face 'org-agenda-structure 'org-agenda-type 'search) "\n")
|
|
;; ;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda,
|
|
;; ;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing.
|
|
;; ;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work.
|
|
;; (let ((org-agenda-sorting-strategy-selected '(category-keep) ))
|
|
;; (->> items
|
|
;; (-map #'org-ql-view--format-element)
|
|
;; org-agenda-finalize-entries
|
|
;; insert))
|
|
;; (insert "\n")))
|
|
|
|
(defun my/get-project-active-displayables (element &optional plus-task)
|
|
(let ((marker (org-element-property :org-marker element)))
|
|
(with-current-buffer (marker-buffer marker)
|
|
(goto-char marker)
|
|
(if (member (org-get-todo-state) '("EMPTY"))
|
|
(list element)
|
|
(cons element
|
|
(let ((display '()))
|
|
(olc/todo-children
|
|
(let ((type (opr/get-type)))
|
|
(when (or (and (eq 'task (opr/get-type))
|
|
(or (and plus-task (eq 'active (opr/type-of-task)))
|
|
(string= "WAIT" (org-get-todo-state))))
|
|
(and (eq 'project (opr/get-type))
|
|
(eq 'active (opr/type-of-project 'active))))
|
|
(let ((res (--> (point)
|
|
(org-element-headline-parser it)
|
|
(org-ql--add-markers it)
|
|
(my/get-project-active-displayables it plus-task)
|
|
(reverse it))))
|
|
(setf display (append res display))))))
|
|
(reverse display)))))))
|
|
|
|
(defun my/get-project-active-displayables-plus-tasks (element)
|
|
(my/get-project-active-displayables element t))
|
|
|
|
(require 'org-dev-level)
|
|
|
|
(defun my/org-ql-active-projects-plus-tasks (tag)
|
|
(let (narrow-p old-beg old-end)
|
|
(let* ((from (or (pcase org-agenda-overriding-restriction
|
|
('nil (org-agenda-files nil 'ifmode))
|
|
('file (get 'org-agenda-files 'org-restrict))
|
|
('subtree (prog1 org-agenda-restrict
|
|
(with-current-buffer org-agenda-restrict
|
|
;; Narrow the buffer; remember to widen it later.
|
|
(setf old-beg (point-min) old-end (point-max)
|
|
narrow-p t)
|
|
(narrow-to-region org-agenda-restrict-begin org-agenda-restrict-end)))))
|
|
(org-agenda-files nil 'ifmode)))
|
|
(org-todo-keywords-1 '("EMPTY" "META" "META1" "ONE" "TODO"))
|
|
(items (mapcan #'my/get-project-active-displayables-plus-tasks
|
|
(org-ql-select from
|
|
`(and ,@(when (and tag
|
|
(not (zerop (length tag))))
|
|
`((tags ,tag)))
|
|
(not (done))
|
|
(odl/part-of-current-level-p)
|
|
,@my/is-project-short-circuit
|
|
(eq 'active (opr/type-of-project 'active)))
|
|
:action 'element-with-markers
|
|
:narrow narrow-p
|
|
:sort 'todo))))
|
|
|
|
(when narrow-p
|
|
;; Restore buffer's previous restrictions.
|
|
(with-current-buffer from
|
|
(narrow-to-region old-beg old-end)))
|
|
(org-agenda-prepare)
|
|
;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than
|
|
;; I'm using. Should probably declare it as a minimum Org version after upgrading.
|
|
;; (org-agenda--insert-overriding-header (or org-ql-block-header (org-ql-agenda--header-line-format from query)))
|
|
(insert (org-add-props org-ql-block-header
|
|
nil 'face 'org-agenda-structure 'org-agenda-type 'search) "\n")
|
|
;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda,
|
|
;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing.
|
|
;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work.
|
|
(let ((org-agenda-sorting-strategy-selected '(category-keep) ))
|
|
(->> items
|
|
(-map #'org-ql-view--format-element)
|
|
org-agenda-finalize-entries
|
|
insert))
|
|
(insert "\n"))))
|
|
|
|
(defun my/org-ql-active-projects (tag)
|
|
(let (narrow-p old-beg old-end)
|
|
(let* ((from (or (pcase org-agenda-overriding-restriction
|
|
('nil (org-agenda-files nil 'ifmode))
|
|
('file (get 'org-agenda-files 'org-restrict))
|
|
('subtree (prog1 org-agenda-restrict
|
|
(with-current-buffer org-agenda-restrict
|
|
;; Narrow the buffer; remember to widen it later.
|
|
(setf old-beg (point-min) old-end (point-max)
|
|
narrow-p t)
|
|
(narrow-to-region org-agenda-restrict-begin org-agenda-restrict-end)))))
|
|
(org-agenda-files nil 'ifmode)))
|
|
(org-todo-keywords-1 '("EMPTY" "META" "META1" "ONE" "TODO" ))
|
|
(items (mapcan #'my/get-project-active-displayables
|
|
(org-ql-select from
|
|
`(and ,@(when (and tag
|
|
(not (zerop (length tag))))
|
|
`((tags ,tag)))
|
|
(odl/part-of-current-level-p)
|
|
,@my/is-project-short-circuit
|
|
(eq 'active (opr/type-of-project 'active)))
|
|
:action 'element-with-markers
|
|
:narrow narrow-p
|
|
:sort 'todo))))
|
|
|
|
(when narrow-p
|
|
;; Restore buffer's previous restrictions.
|
|
(with-current-buffer from
|
|
(narrow-to-region old-beg old-end)))
|
|
(org-agenda-prepare)
|
|
;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than
|
|
;; I'm using. Should probably declare it as a minimum Org version after upgrading.
|
|
;; (org-agenda--insert-overriding-header (or org-ql-block-header (org-ql-agenda--header-line-format from query)))
|
|
(insert (org-add-props org-ql-block-header
|
|
nil 'face 'org-agenda-structure 'org-agenda-type 'search) "\n")
|
|
;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda,
|
|
;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing.
|
|
;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work.
|
|
(let ((org-agenda-sorting-strategy-selected '(category-keep) ))
|
|
(->> items
|
|
(-map #'org-ql-view--format-element)
|
|
org-agenda-finalize-entries
|
|
insert))
|
|
(insert "\n"))))
|
|
|
|
(defun my/org-ql-get-restriciton ())
|
|
|
|
;; (test-stuck-projects)
|
|
|
|
(provide 'org-ql-custom-stuck-projects)
|
|
;;; org-ql-custom-stuck-projects.el ends here
|