ADD org dag library (kinda)
This commit is contained in:
parent
154ba9248c
commit
61076a2b90
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue