From 61076a2b902df6822e02b46cb3371bd6cc3872d9 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 15 Jan 2022 00:41:11 -0500 Subject: [PATCH] ADD org dag library (kinda) --- local/lib/dag/dag.el | 37 ++- local/lib/org-x/org-x-dag.el | 599 +++++++++++++++++++++++++++++++++++ local/lib/org-x/org-x.el | 9 +- 3 files changed, 631 insertions(+), 14 deletions(-) create mode 100644 local/lib/org-x/org-x-dag.el diff --git a/local/lib/dag/dag.el b/local/lib/dag/dag.el index 77b1547..efdf516 100644 --- a/local/lib/dag/dag.el +++ b/local/lib/dag/dag.el @@ -73,22 +73,22 @@ The type of WHAT will determine how the hash table is build: (defun dag--ht-remove (h k x) (ht-set h k (remove x (ht-get h k)))) -(defun dag--adjlist-get-relationships (key adjlist) +(defun dag--adjlist-get-relations (key adjlist) (ht-get adjlist key)) -(defun dag--relationship-get-children (rel) +(defun dag-relation-get-children (rel) (plist-get rel :children)) -(defun dag--relationship-get-parents (rel) +(defun dag-relation-get-parents (rel) (plist-get rel :parents)) (defun dag--adjlist-get-children (key adjlist) (->> (ht-get adjlist key) - (dag--relationship-get-children))) + (dag-relation-get-children))) (defun dag--adjlist-get-parents (key adjlist) (->> (ht-get adjlist key) - (dag--relationship-get-parents))) + (dag-relation-get-parents))) (defun dag--new-relationship (p c) (list :parents p :children c)) @@ -168,7 +168,7 @@ The type of WHAT will determine how the hash table is build: ;; a list of 'broken' parent edges. ;; ;; O(E+N) - (--each (ht-keys h) + (dag--each-key h (setq relations (ht-get h it) parents (plist-get relations :parents)) (while parents @@ -394,32 +394,45 @@ Return a DAG object." (defun dag-is-valid-p (dag) (< 0 (dag-get-length dag))) +(defun dag-get-node (key dag) + (-some-> (dag-get-adjacency-list dag) + (ht-get key))) + (defun dag-get-relationships (key dag) (->> (dag-get-adjacency-list dag) - (dag--adjlist-get-relationships key))) + (dag--adjlist-get-relations key))) (defun dag-get-parents (key dag) (->> (dag-get-relationships key dag) - (dag--relationship-get-parents))) + (dag-relation-get-parents))) (defun dag-get-children (key dag) (->> (dag-get-relationships key dag) - (dag--relationship-get-children))) + (dag-relation-get-children))) -(defmacro dag-get-nodes-where (dag form) +(defmacro dag-get-nodes-and-edges-where (dag form) (declare (indent 1)) `(let ((it-adjlist (dag-get-adjacency-list ,dag)) + acc it-rel) + (dag--each-key it-adjlist + (setq it-rel (ht-get it-adjlist it)) + (when ,form (!cons (cons it it-rel) acc))) + acc)) + +(defmacro dag-get-floating-nodes-where (dag form) + (declare (indent 1)) + `(let ((it-adjlist (dag-get-floating-nodes ,dag)) acc) (dag--each-key it-adjlist (when ,form (!cons it acc))) acc)) (defun dag-get-leaf-nodes (dag) - (dag-get-nodes-where dag + (dag-get-nodes-and-edges-where dag (not (dag--adjlist-get-children it it-adjlist)))) (defun dag-get-root-nodes (dag) - (dag-get-nodes-where dag + (dag-get-nodes-and-edges-where dag (not (dag--adjlist-get-parents it it-adjlist)))) (defun dag-get-extra-nodes (dag) diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el new file mode 100644 index 0000000..6bb2f93 --- /dev/null +++ b/local/lib/org-x/org-x-dag.el @@ -0,0 +1,599 @@ +;;; org-x-dag.el --- Org-in-a-DAG -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Nathan Dwarshuis + +;; 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: + +;; Welcome to Dagestan, you will be smeshed... + +;;; Code: + +;; TODO this depends on other stuff in org-x like the file and id operations +(require 'org) +(require 'org-ml) +(require 'dash) +(require 'dag) +(require 'ht) + +;;; GLOBAL STATE + +;; variables to store state + +(defvar org-x-dag nil + "The org-x DAG. + +Each node in this DAG represents a headline with the following +characteristics: +- contained in a file as given by `org-x-dag-get-files' +- has a keyword +- either has an immediate parent with a keyword or has no parents + with keywords + +Each node is represented by a key, which is either a string +representing the headlines's ID property or a cons cell +like (FILE POS) representing the staring position in file/buffer +of the headline (aka a \"pseudo-marker\").") + +;; TODO might be better if I make one giant variable to hold these things, the +;; dag, and whatever else I decide should be cached to death +(defvar org-x-dag-node-tags-table nil) +(defvar org-x-dag-file-tags-table nil) + +(defvar org-x-dag-sync-state nil + "An alist representing the sync state of the DAG. + +The car of each cell is the file path, and the cdr is the md5 of +that file as it currently sits on disk.") + +;; functions to construct nodes within state + +(defun org-x-dag-build-key (file point level todo tags id) + (list :file file + :point point + :level level + :todo todo + :tags tags + :id id)) + ;; (if id (list :id file point id) (list :pm file point))) + +(defun org-x-dag-key-get-file (key) + "Return file for KEY." + (plist-get key :file)) + ;; (nth 1 key)) + +(defun org-x-dag-key-get-point (key) + "Return point for KEY." + (plist-get key :point)) + ;; (nth 2 key)) + +;;; DAG SYNCHRONIZATION/CONSTRUCTION + +(defun org-x-dag-get-files () + "Return a list of all files to be used in the DAG." + `(,(org-x-get-lifetime-goal-file) + ,(org-x-get-endpoint-goal-file) + ,@(org-x-get-action-files))) + +(defun org-x-dag-get-md5 (path) + "Get the md5 checksum of PATH." + (with-temp-buffer + (let ((rc (call-process "md5sum" nil (current-buffer) nil path))) + (if (/= 0 rc) (error "Could not get md5 of %s" path) + (->> (buffer-string) + (s-match "^\\([0-9a-z]+\\)") + (cadr)))))) + +(defun org-x-dag-md5-matches-p (path md5) + "Return t if the md5 of PATH on disk `equal's MD5." + (equal (org-x-dag-get-md5 path) md5)) + +(defun org-x-dag-file-is-dirty (file md5) + "Return t if FILE with MD5 has been recently changed." + (or (org-x-with-file file (buffer-modified-p)) + (not (org-x-dag-md5-matches-p file md5)))) + +(defun org-x-dag-set-sync-state () + "Set the sync state to reflect the current files on disk." + (->> (org-x-dag-get-files) + (--map (cons it (org-x-dag-get-md5 it))) + (setq org-x-dag-sync-state))) + +(defun org-x-dag-get-sync-state () + "Return the sync state. + +The returned value will be a list like (TO-REMOVE TO-INSERT +TO-UPDATE) which will contain the file paths the should be +removed from, added to, or edited within the DAG respectively." + (cl-flet + ((states-to-files + (states) + (-map #'car states))) + (-let* (((exist noexist) + (--separate (f-exists-p (car it)) org-x-dag-sync-state)) + (to-remove (states-to-files noexist)) + (to-insert (->> (states-to-files exist) + (-difference (org-x-dag-get-files)))) + (to-update (->> exist + (--filter (-let (((file . md5) it)) + (org-x-dag-file-is-dirty file md5))) + (states-to-files)))) + (list to-remove to-insert to-update)))) + +;; TODO this assumes the `org-id-locations' is synced +(defun org-x-dag-get-buffer-nodes (file kws) + "Return a list of nodes from FILE. + +A node will only be returned if the headline to which it points +has a valid (meaning in KWS) keyword and either its parent has a +valid keyword or none of its parents have valid keywords." + (let ((more t) + cur-path this-point this-key this-level this-todo has-todo this-parent + tags acc) + ;; TODO add org-mode sanity check + (goto-char (point-min)) + ;; move forward until on a headline + (while (and (not (= ?* (following-char))) (= 0 (forward-line 1)))) + ;; Build alist; Keep track of how 'deep' we are in a given org-tree using a + ;; stack. The stack will have members like (LEVEL KEY) where LEVEL is the + ;; level of the headline and KEY is the node key if it has a keyword. Only + ;; add a node to the accumulator if it has a keyword, and only include its + ;; parent headline if the parent also has a keyword (add the link targets + ;; regardless). + (while more + (when (= ?* (following-char)) + (setq this-point (point) + this-key nil) + ;; Get tags (must be done from the first column) + (setq this-tags (org--get-local-tags)) + ;; Get the level + (while (= ?* (following-char)) (forward-char 1)) + (setq this-level (current-column)) + ;; Check if the headline has a keyword + (forward-char 1) + (while (not (memq (following-char) '(? ?\n))) (forward-char 1)) + (setq this-todo (-> (+ 1 this-point this-level) + (buffer-substring (+ this-point (current-column)))) + has-todo (member this-todo kws)) + ;; Adjust the stack so that the top headline is the parent of the + ;; current headline + (while (and cur-path (<= this-level (nth 0 (car cur-path)))) + (!cdr cur-path)) + (setq this-parent (car cur-path)) + ;; Add the current headline to accumulator if it has a keyword, but only + ;; if its parent has a keyword or none of its parents have keywords + (when (and has-todo (or (nth 1 this-parent) + (--none-p (nth 1 it) cur-path))) + ;; If parent is not a todo and we want tag inheritance, store all tags + ;; above this headline (sans file-tags which we can get later easily) + (setq tags (if (and (not (nth 1 this-parent)) org-use-tag-inheritance) + (->> cur-path + (--mapcat (nth 2 it)) + (append this-tags)) + this-tags) + this-key (org-x-dag-build-key file + this-point + this-level + (substring-no-properties this-todo) + tags + (org-entry-get nil "ID"))) + ;; TODO also get a list of link parent targets and add them to the + ;; parent list + (!cons (cons this-key (-some-> (nth 1 this-parent) (list))) acc)) + ;; Add current headline to stack + ;; (when (and (s-contains-p "general" file) (not (nth 1 this-parent))) + ;; (print (--map (nth 2 it) cur-path))) + ;; (print (list cur-path this-tags))) + (!cons (list this-level this-key this-tags) cur-path)) + (setq more (= 0 (forward-line 1)))) + (nreverse acc))) + +(defun org-x-dag-get-file-nodes (file) + "Return all nodes in FILE in one pass." + (org-x-with-file file + (org-x-dag-get-buffer-nodes file org-todo-keywords-1))) + +;; (defun org-x-dag-key-is-pseudo-marker (key) +;; "Return t if KEY is a pseudo marker." +;; (eq (car key) :pm)) +;; ;; (= 2 (length key))) +;; ;; (and (consp key) (stringp (car key)) (numberp (cdr key)))) + +;; (defun org-x-dag-key-is-id (key) +;; "Return t if KEY is an ID." +;; ;; (= 3 (length key))) +;; (eq (car key) :id)) + +(defun org-x-dag-files-contains-key-p (key files) + "Return t if KEY represents a node contained in FILES." + (-if-let (other-file (org-x-dag-key-get-file key)) + (--any-p (equal other-file it) files) + (error "Invalid key: %s" key))) + ;; (cl-flet + ;; ((contains-key + ;; (files other-file) + ;; (--any-p (equal other-file it) files))) + ;; (cond + ;; ((org-x-dag-key-is-id key) + ;; (-some->> (ht-get org-id-locations key) + ;; (contains-key files))) + ;; ((org-x-dag-key-is-pseudo-marker key) + ;; (contains-key files (car key))) + ;; (t + ;; (error "Invalid key: %s" key))))) + +(defun org-x-dag-get-nodes-in-files (dag files) + (dag-get-nodes-and-edges-where org-x-dag + (org-x-dag-files-contains-key-p it files))) + +(defun org-x-dag-build-tag-tables (nodes &optional node-tags file-tags) + "Create hash tables for the tags from NODES. + +Two tables will be returned, one for the local tags of each node, +and one for the file tags for each file represented by NODES." + (let ((node-tags (or node-tags (ht-create #'equal))) + (file-tags (or file-tags (ht-create #'equal)))) + (-> (-group-by #'org-x-dag-key-get-file nodes) + (--each (-let (((path . nodes) it)) + (org-x-with-file path + (ht-set file-tags path org-file-tags) + (--each nodes + (goto-char (org-x-dag-key-get-point it)) + (ht-set node-tags it (org-get-tags nil t))))))) + (list node-tags file-tags))) + +(defun org-x-dag-tags-table-remove (nodes node-tags file-tags) + (--each nodes + (ht-remove node-tags it) + (ht-remove file-tags it)) + (list node-tags file-tags)) + +(defun org-x-dag-tags-table-update (to-remove to-insert) + (-setq (org-x-dag-node-tags-table org-x-dag-file-tags-table) + (->> (org-x-dag-tags-table-remove to-remove + org-x-dag-node-tags-table + org-x-dag-file-tags-table) + (apply #'org-x-dag-build-tag-tables to-insert)))) + +(defun org-x-dag-update (to-remove to-insert to-update) + "Update the DAG given files to add and remove. + +TO-REMOVE, TO-INSERT, and TO-UPDATE are lists of files to remove +from, add to, and update with the DAG." + (let* ((files-to-insert (append to-update to-insert)) + (nodes-to-insert (-mapcat #'org-x-dag-get-file-nodes files-to-insert))) + (if org-x-dag + (let* ((files-to-remove (append to-update to-remove)) + (nodes-to-remove (org-x-dag-get-nodes-in-files + org-x-dag files-to-remove))) + (setq org-x-dag (dag-edit-nodes nodes-to-remove + nodes-to-insert + org-x-dag)) + (org-x-dag-tags-table-update (-map #'car nodes-to-remove) + (-map #'car nodes-to-insert))) + (org-x-dag-tags-table-update nil (-map #'car nodes-to-insert)) + (setq org-x-dag (dag-alist-to-dag nodes-to-insert))))) + +(defun org-x-dag-sync (&optional force) + "Sync the DAG with files from `org-x-dag-get-files'. + +If FORCE is non-nil, sync no matter what." + (when force + (setq org-x-dag-sync-state nil + org-x-dag nil)) + (-let (((to-remove to-insert to-update) (org-x-dag-get-sync-state))) + (org-x-dag-update to-remove to-insert to-update) + (org-x-dag-set-sync-state) + nil)) + +;;; DAG -> HEADLINE RETRIEVAL + +(defun org-x-dag-relation-has-parent-headlines-p (key relation) + "" + (let ((this-file (org-x-dag-key-get-file key))) + (->> (dag-relation-get-parents relation) + (--any-p (equal this-file (org-x-dag-key-get-file it)))))) + +(defun org-x-dag-relation-has-child-headlines-p (key relation) + "" + (let ((this-file (org-x-dag-key-get-file key))) + (->> (dag-relation-get-children relation) + (--any-p (equal this-file (org-x-dag-key-get-file it)))))) + +(defun org-x-dag-get-standalone-task-nodes (dag) + "Return the standalone task nodes of DAG." + (let* ((action-files (org-x-get-action-files)) + (from-adjlist + (dag-get-nodes-and-edges-where dag + (and (org-x-dag-files-contains-key-p it action-files) + (not (org-x-dag-relation-has-parent-headlines-p it it-rel)) + (not (org-x-dag-relation-has-child-headlines-p it it-rel))))) + (from-floating + (dag-get-floating-nodes-where dag + (org-x-dag-files-contains-key-p it action-files)))) + (append (-map #'car from-adjlist) from-floating))) + +(defun org-x-dag-get-toplevel-project-nodes (dag) + "Return the toplevel project nodes of DAG." + (let ((action-files (org-x-get-action-files))) + (dag-get-nodes-and-edges-where dag + (and (org-x-dag-files-contains-key-p it action-files) + (not (org-x-dag-relation-has-parent-headlines-p it it-rel)) + (org-x-dag-relation-has-child-headlines-p it it-rel))))) + +;;; DAG -> HEADLINE RETRIEVAL (CHILD/PARENT) + +(defun org-x-dag-filter-children (dag key fun) + (declare (indent 2)) + (-filter fun (dag-get-children key dag))) + +(defun org-x-dag-separate-children (dag key fun) + (declare (indent 2)) + (-separate fun (dag-get-children key dag))) + +(defun org-x-dag-node-get-headline-children (dag key) + (let ((this-file (org-x-dag-key-get-file key))) + (org-x-dag-filter-children dag key + (lambda (it) (equal this-file (org-x-dag-key-get-file it)))))) + +;; TODO somewhere in here I need to filter based on headline like CANC +(defun org-x-dag-project-node-get-task-nodes (dag key) + (declare (indent 2)) + ;; NOTE if this is a standalone task it will return itself + (-if-let (cs (org-x-dag-node-get-headline-children dag key)) + (--mapcat (org-x-dag-project-node-get-task-nodes dag it) cs) + (list key))) + +(defun org-x-dag-get-project-task-nodes (dag) + "Return project task nodes of DAG." + (-let (((&plist :adjlist) dag)) + (->> (org-x-dag-get-toplevel-project-nodes dag) + (-map #'car) + (--mapcat (org-x-dag-project-node-get-task-nodes dag it))))) + +(defun org-x-dag-project-node-get-subproject-nodes (dag key) + (-when-let (cs (org-x-dag-node-get-headline-children dag key)) + (cons key (--mapcat (org-x-dag-project-node-get-subproject-nodes dag it) cs)))) + +(defun org-x-dag-get-subproject-task-nodes (dag) + "Return subproject nodes of DAG." + ;; ignore floating nodes since these by definition can't be part of projects + (-let (((&plist :adjlist) dag)) + (->> (org-x-dag-get-toplevel-project-nodes dag) + (-map #'car) + (--mapcat (org-x-dag-project-node-get-subproject-nodes dag it))))) + +;; (defmacro org-x-dag-with-key (key &rest body) +;; (declare (indent 1)) +;; `(cond +;; ((org-x-dag-key-is-pseudo-marker ,key) +;; (org-x-with-file (car ,key) +;; (goto-char (cdr ,key)) +;; ,@body)) +;; ((org-x-dag-key-is-id ,key) +;; (org-x-with-id-target ,key +;; ,@body)))) + +;; NODE FORMATTING + +(defun org-x-dag-get-headline-with-props (pos type face) + (goto-char pos) + (let* ((head (org-get-heading)) + (level (-> (org-outline-level) + (org-reduced-level) + (1-) + (make-string ?.))) + (category (org-get-category)) + (todo-state (org-get-todo-state)) + (inherited-tags + (or (eq org-agenda-show-inherited-tags 'always) + (and (listp org-agenda-show-inherited-tags) + (memq 'agenda org-agenda-show-inherited-tags)) + (and (eq org-agenda-show-inherited-tags t) + (or (eq org-agenda-use-tag-inheritance t) + (memq 'agenda + org-agenda-use-tag-inheritance))))) + (tags (org-get-tags nil (not inherited-tags))) + (item (org-agenda-format-item "" head level category tags nil nil nil)) + (marker (org-agenda-new-marker pos))) + (org-add-props item nil + 'org-marker marker + 'org-hd-marker marker + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'mouse-face 'highlight + 'help-echo (format "mouse-2 or RET jump to Org file %s" + (abbreviate-file-name buffer-file-name)) + 'undone-face face + ;; TODO in the case of scheduled headline this has other stuff in it + 'priority (org-get-priority item) + 'todo-state todo-state + 'face face + 'type type))) + +(defun org-x-dag-nodes-to-headlines (nodes) + (->> (-group-by #'org-x-dag-key-get-file nodes) + (--map (-let (((path . nodes) it)) + (org-x-with-file path + (->> (-map #'org-x-dag-key-get-point nodes) + (--map (progn (goto-char it) + (substring-no-properties (org-get-heading)))))))) + ;; (->> (-map #'org-x-dag-key-get-point nodes) + ;; (-map #'org-x-dag-get-headline-with-props))))) + (-flatten-n 1))) + +(defun org-x-dag-collapse-tags (tags) + "Return TAGS with duplicates removed. + +In the case of mutually exclusive tags, only the first tag +encountered will be returned." + (-let (((x non-x) (--separate (memq (elt it 0) org-x-exclusive-prefixes) tags))) + (->> (--group-by (elt it 0) x) + (--map (car (cdr it)) ) + (append (-uniq non-x))))) + +(defun org-x-dag-add-default-props (item) + (org-add-props item nil + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'mouse-face 'default)) + +;; TODO this doesn't even use the tags cache...hmmm +(defun org-x-dag-format-tag-node (tags key) + (-let* ((category (org-get-category)) + (head (org-get-heading)) + (level (-> (plist-get key :level) + (make-string ?s))) + ;; (tags (-> (plist-get key :tags) + ;; (append parent-tags) + ;; (org-x-dag-collapse-tags))) + ;; no idea what this does... + (help-echo (format "mouse-2 or RET jump to Org file %S" + (abbreviate-file-name + (or (buffer-file-name (buffer-base-buffer)) + (buffer-name (buffer-base-buffer)))))) + (marker (org-agenda-new-marker)) + (priority (org-get-priority head)) + (todo-state (plist-get key :todo)) + ;; no idea what this function actually does + ((ts . ts-type) (org-agenda-entry-get-agenda-timestamp (point)))) + (-> (org-agenda-format-item "" head level category tags) + (org-x-dag-add-default-props) + (org-add-props nil + ;; face + 'face 'default + 'done-face 'org-agenda-done + 'undone-face 'default + ;; marker + 'org-hd-marker marker + 'org-marker marker + ;; headline stuff + 'todo-state todo-state + 'priority priority + 'ts-date ts + ;; misc + 'type (concat "tagsmatch" ts-type) + 'help-echo help-echo)))) + +(defun org-x-dag-scan-tasks () + (let* ((dag org-x-dag)) + (->> (org-x-dag-get-project-task-nodes dag) + (append (org-x-dag-get-standalone-task-nodes dag)) + (--group-by (org-x-dag-key-get-file it)) + (--mapcat + (-let (((path . keys) it)) + (org-x-with-file path + (--map + (let ((tags (->> (org-x-dag-get-inherited-tags org-file-tags dag it) + (append (plist-get it :tags)) + (org-x-dag-collapse-tags)))) + (unless (member org-x-tag-incubated tags) + (goto-char (org-x-dag-key-get-point it)) + (org-x-dag-format-tag-node tags it))) + keys)))) + (-non-nil)))) + + +(defun org-x-dag-scan-tags () + (let* ((dag org-x-dag) + (nodes (org-x-dag-get-toplevel-project-nodes dag))) + (->> (--group-by (org-x-dag-key-get-file (car it)) nodes) + (--mapcat + (-let (((path . nodes) it)) + (org-x-with-file path + (->> (-map #'car nodes) + (--mapcat + (progn + (goto-char (org-x-dag-key-get-point it)) + (org-x-dag-format-tag-node dag (org-get-tags (point)) it)))))))))) + +(defun org-x-dag-get-inherited-tags (init dag key) + (let* ((this-file (org-x-dag-key-get-file key))) + (cl-labels + ((ascend + (k tags) + (-if-let (parent (->> (dag-get-parents k dag) + (--first (equal (org-x-dag-key-get-file it) + this-file)))) + (->> (plist-get parent :tags) + (append tags) + (ascend parent)) + tags))) + (org-x-dag-collapse-tags (append (ascend key nil) init))))) + +;;; AGENDA VIEWS + +(defun org-x-dag-get-day-entries (_ date &rest args) + "Like `org-agenda-get-day-entries' but better." + ;; for now just return a list of standalone tasks + (->> (org-x-dag-get-standalone-task-nodes org-x-dag) + (org-x-dag-nodes-to-headlines))) + +(defun org-x-dag-agenda-list () + (let ((org-agenda-files (org-x-get-action-files))) + (nd/with-advice + (('org-agenda-get-day-entries :override #'org-x-dag-get-day-entries)) + (org-agenda-list)))) + +(defun org-x-dag-tags-view (_match) + (org-x-dag-sync t) + (let ((org-agenda-files (org-x-get-action-files))) + (nd/with-advice + (('org-scan-tags :override (lambda (&rest _) (org-x-dag-scan-tags)))) + (org-tags-view '(4) "TODO")))) + +(defun org-x-dag-show-tasks (_match) + (org-x-dag-sync t) + ;; hack to make the loop only run once + (let ((org-agenda-files (list (car (org-x-get-action-files))))) + (nd/with-advice + (('org-scan-tags :override (lambda (&rest _) (org-x-dag-scan-tasks)))) + (org-tags-view '(4) "TODO")))) + +(defun org-x-dag-show-nodes (get-nodes) + (let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels) + (completion-ignore-case t) + rtnall files file pos matcher + buffer) + (catch 'exit + (org-agenda-prepare (concat "DAG-TAG")) + (org-compile-prefix-format 'tags) + (org-set-sorting-strategy 'tags) + (let ((org-agenda-redo-command `(org-x-dag-show-nodes ',get-nodes)) + (rtnall (funcall get-nodes))) + (org-agenda--insert-overriding-header + (with-temp-buffer + (insert "Headlines with TAGS match: \n") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure)) + (buffer-string))) + (org-agenda-mark-header-line (point-min)) + (when rtnall + (insert (org-agenda-finalize-entries rtnall 'tags) "\n")) + (goto-char (point-min)) + (or org-agenda-multi (org-agenda-fit-window-to-buffer)) + (add-text-properties + (point-min) (point-max) + `(org-agenda-type tags + org-last-args (,get-nodes) + org-redo-cmd ,org-agenda-redo-command + org-series-cmd ,org-cmd)) + (org-agenda-finalize) + (setq buffer-read-only t))))) + +(provide 'org-x-dag) +;;; org-x-dag.el ends here diff --git a/local/lib/org-x/org-x.el b/local/lib/org-x/org-x.el index 576a2e7..377abc4 100644 --- a/local/lib/org-x/org-x.el +++ b/local/lib/org-x/org-x.el @@ -37,6 +37,7 @@ (require 'org) (require 'org-id) (require 'org-x-agg) +(require 'org-x-dag) ;;; TODO KEYWORDS @@ -82,6 +83,10 @@ (defconst org-x-tag-category-prefix ?_ "Prefix character denoting life category tag.") +(defconst org-x-exclusive-prefixes (list org-x-tag-category-prefix + org-x-tag-location-prefix) + "Tag prefixes which denote mutually exclusive groups.") + (defconst org-x-tag-errand (org-x-prepend-char org-x-tag-location-prefix "errand") "Tag denoting an errand location.") @@ -1106,13 +1111,13 @@ should be this function again)." i (message "WARNING: invalid id found: %s" i)))) -(defmacro org-x-with-id-target (id form) +(defmacro org-x-with-id-target (id &rest body) (declare (indent 1)) `(-when-let ((it-file . it-point) (org-id-find ,id)) (org-x-with-file it-file (save-excursion (goto-char it-point) - ,form)))) + ,@body)))) (defun org-x-goal-build-link (id) (org-x-with-id-target id