changeset 651: |
af486e0a40c9 |
parent: |
6c0e4a44c082
|
child: |
328e1ff73938 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sat, 14 Sep 2024 22:13:06 -0400 |
permissions: |
-rw-r--r-- |
description: |
multi-binaries, working on removing x.lisp |
1 ;;; graph.el --- Graph-oriented Extensions -*- lexical-binding: t; -*- 3 ;; Copyright (C) 2024 The Compiler Company 5 ;; Author: Richard Westhaver <richard.westhaver@gmail.com> 6 ;; Keywords: docs, maint, outlines, extensions 8 ;; This program is free software; you can redistribute it and/or modify 9 ;; it under the terms of the GNU General Public License as published by 10 ;; the Free Software Foundation, either version 3 of the License, or 11 ;; (at your option) any later version. 13 ;; This program is distributed in the hope that it will be useful, 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; GNU General Public License for more details. 18 ;; You should have received a copy of the GNU General Public License 19 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 34 (defcustom org-graph-db-directory (join-paths user-org-stash-directory "graph") 35 "graph database storage directory." 39 (defcustom org-graph-locations (list (join-paths company-org-directory "notes")) 40 "List of directories to check for nodes." 41 :type '(list directory) 44 (defcustom org-graph-include-agenda-files nil 45 "When non-nil, include `org-agenda-files' in the graph." 49 (defcustom org-graph-include-archive nil 50 "When non-nil, include `org-arhive-location' in the graph." 54 (defcustom org-graph-include-org-directory nil 55 "When non-nil, include `org-directory' files in the graph." 59 (defcustom org-graph-compaction-hook nil 60 "Hook run when a graph is compacted to `org-graph-db'." 64 (defcustom org-graph-capture-hook nil 65 "Hook run when a node is added to the graph." 69 (defvar-local org-graph nil 70 "The currently active graph of org nodes.") 72 (defcustom org-graph-db-init-script (join-paths company-source-directory "infra/scripts/org-db-init.lisp") 73 "Path to a lisp script responsible for initializing the `org-graph-db-directory'.") 75 (cl-defstruct org-graph-db-handle 85 (defcustom org-graph-db (make-org-graph-db-handle) 86 "A handle to the database backend which stores nodes and edges." 87 :type 'org-graph-db-handle 90 (defun org-graph-from-id-locations () 91 "Populate the `org-graph' from `org-id-locations', filtering out any 92 entries not under a member of `org-graph-locations'." 94 (setq-local org-graph (copy-hash-table (org-id-locations-load))) 99 (unless (string-prefix-p x (file-truename v)) 100 (remhash k org-graph))) 101 org-graph-locations)) 104 (defun org-dblock-write:links () 105 "Generate a 'links' block for the designated node.") 107 (defun org-dblock-write:graph () 108 "Generate a 'graph' block for the designated set of nodes.") 111 ;; See https://github.com/toshism/org-super-links/blob/develop/org-super-links.el 112 (declare-function org-make-link-description-function "ext:org-mode") 114 (defvar org-graph-edge-backlink-into-drawer "LINKS" 115 "Controls how/where to insert the backlinks. 116 If non-nil a drawer will be created and backlinks inserted there. The 117 default is BACKLINKS. If this is set to a string a drawer will be 118 created using that string. For example LINKS. If nil backlinks will 119 just be inserted under the heading.") 121 (defvar org-graph-edge-backlink-prefix 'org-graph-edge-backlink-prefix-timestamp 122 "Prefix to insert before the backlink. 123 This can be a string, nil, or a function that takes no arguments and 126 Default is the function `org-graph-edge-backlink-prefix-timestamp' 127 which returns an inactive timestamp formatted according to the variable 128 `org-time-stamp-formats' and a separator ' <- '.") 130 (defvar org-graph-edge-backlink-postfix nil 131 "Postfix to insert after the backlink. 132 This can be a string, nil, or a function that takes no arguments and 135 (defvar org-graph-edge-related-into-drawer nil 136 "Controls how/where to insert links. 137 If non-nil a drawer will be created and links inserted there. The 138 default is `org-graph-edge-related-drawer-default-name'. If this is set to a 139 string a drawer will be created using that string. For example LINKS. 140 If nil links will just be inserted at point.") 142 (defvar org-graph-edge-related-drawer-default-name "RELATED" 143 "Default name to use for link drawer. 144 If variable `org-graph-edge-related-into-drawer' is 't' use this 145 name for the drawer. See variable `org-graph-edge-related-into-drawer' for more info.") 147 (defvar org-graph-edge-link-prefix nil 148 "Prefix to insert before the link. 149 This can be a string, nil, or a function that takes no arguments and 152 (defvar org-graph-edge-link-postfix nil 153 "Postfix to insert after the link. 154 This can be a string, nil, or a function that takes no arguments and 157 (defvar org-graph-edge-default-description-formatter org-make-link-description-function 158 "What to use if no description is provided. 159 This can be a string, nil or a function that accepts two arguments 160 LINK and DESC and returns a string. 162 nil will return the default desciption or the link. 163 string will be used only as a default fall back if set. 164 function will be called for every link. 166 Default is the variable `org-make-link-desciption-function'.") 168 (defvar org-graph-edge-search-function 169 (cond ((require 'helm-org-ql nil 'no-error) "helm-org-ql") 170 ((require 'helm-org-rifle nil 'no-error) "helm-org-rifle") 171 (t 'org-graph-edge-get-location)) 172 "The interface to use for finding target links. 173 This can be a string with one of the values 'helm-org-ql', 174 'helm-org-rifle', or a function. If you provide a custom 175 function it will be called with the `point` at the location the link 176 should be inserted. The only other requirement is that it should call 177 the function `org-graph-edge--insert-link' with a marker to the target link. 178 AKA the place you want the backlink. 180 Using 'helm-org-ql' or 'helm-org-rifle' will also add a new 181 action to the respective action menu. 183 See the function `org-graph-edge-link-search-interface-ql' or for an example. 185 Default is set based on currently installed packages. In order of priority: 188 - `org-graph-edge-get-location' 190 `org-graph-edge-get-location' internally uses `org-refile-get-location'.") 192 (defvar org-graph-edge-pre-link-hook nil 193 "Hook called before storing the link on the link side. 194 This is called with point at the location where it was called.") 196 (defvar org-graph-edge-pre-backlink-hook nil 197 "Hook called before storing the link on the backlink side. 198 This is called with point in the heading of the backlink.") 200 (declare-function org-graph-edge-org-ql-link-search-interface "ext:org-graph-edge-org-ql") 201 (declare-function org-graph-edge-org-rifle-link-search-interface "ext:org-graph-edge-org-rifle") 203 (defun org-graph-edge-get-location () 204 "Default for function `org-graph-edge-search-function' that reuses the `org-refile' machinery." 205 (let ((target (org-refile-get-location "Super Link"))) 206 (org-graph-edge--insert-link (set-marker (make-marker) (car (cdddr target)) 207 (get-file-buffer (car (cdr target))))))) 209 (defun org-graph-edge-search-function () 210 "Call the search interface specified in variable `org-graph-edge-search-function'." 211 (cond ((string= org-graph-edge-search-function "helm-org-ql") 212 (require 'org-graph-edge-org-ql) 213 (org-graph-edge-org-ql-link-search-interface)) 214 ((string= org-graph-edge-search-function "helm-org-rifle") 215 (require 'org-graph-edge-org-rifle) 216 (org-graph-edge-org-rifle-link-search-interface)) 217 (t (funcall org-graph-edge-search-function)))) 219 (defun org-graph-edge-backlink-prefix () 220 "Return an appropriate string based on variable `org-graph-edge-backlink-prefix'." 221 (cond ((equal org-graph-edge-backlink-prefix nil) "") 222 ((stringp org-graph-edge-backlink-prefix) org-graph-edge-backlink-prefix) 223 (t (funcall org-graph-edge-backlink-prefix)))) 225 (defun org-graph-edge-backlink-postfix () 226 "Return an appropriate string based on variable `org-graph-edge-backlink-postfix'." 227 (cond ((equal org-graph-edge-backlink-postfix nil) "\n") 228 ((stringp org-graph-edge-backlink-postfix) org-graph-edge-backlink-postfix) 229 (t (funcall org-graph-edge-backlink-postfix)))) 231 (defun org-graph-edge-link-prefix () 232 "Return an appropriate string based on variable `org-graph-edge-link-prefix'." 233 (cond ((equal org-graph-edge-link-prefix nil) "") 234 ((stringp org-graph-edge-link-prefix) org-graph-edge-link-prefix) 235 (t (funcall org-graph-edge-link-prefix)))) 237 (defun org-graph-edge-link-postfix () 238 "Return an appropriate string based on variable `org-graph-edge-link-postfix'." 239 (cond ((equal org-graph-edge-link-postfix nil) "") 240 ((stringp org-graph-edge-link-postfix) org-graph-edge-link-postfix) 241 (t (funcall org-graph-edge-link-postfix)))) 243 (defun org-graph-edge-backlink-prefix-timestamp () 244 "Return the default prefix string for a backlink. 245 Inactive timestamp formatted according to `org-time-stamp-formats' and 247 (concat (format-time-string (org-time-stamp-format t t) (current-time)) 250 (defun org-graph-edge-default-description-formatter (link desc) 251 "Return a string to use as the link desciption. 252 LINK is the link target. DESC is the provided desc." 253 (let ((p org-graph-edge-default-description-formatter)) 254 (cond ((equal p nil) (or desc link)) 255 ((stringp p) (or desc p)) 256 ((fboundp p) (funcall p link desc)) 259 (defun org-graph-edge-backlink-into-drawer () 260 "Name of the backlink drawer, as a string, or nil. 261 This is the value of variable 262 `org-graph-edge-backlink-into-drawer'. However, if the current 263 entry has or inherits a BACKLINK_INTO_DRAWER property, it will be 264 used instead of the default value." 265 (let ((p (org-entry-get nil "BACKLINK_INTO_DRAWER" 'inherit t))) 266 (cond ((equal p "nil") nil) 267 ((equal p "t") "BACKLINKS") 270 ((stringp org-graph-edge-backlink-into-drawer) org-graph-edge-backlink-into-drawer) 271 (org-graph-edge-backlink-into-drawer "BACKLINKS")))) 273 ;; delete related functions 274 (defun org-graph-edge--find-link (id) 275 "Return link element for ID." 277 (org-graph-edge--org-narrow-to-here) 279 (org-element-map (org-element-parse-buffer) 'link 281 (when (string= (org-element-property :path link) id) 284 (if (> (length link) 1) 285 (error "Multiple links found. Canceling delete") 288 (defun org-graph-edge--org-narrow-to-here () 289 "Narrow to current heading, excluding subheadings." 290 (org-narrow-to-subtree) 292 (org-next-visible-heading 1) 293 (narrow-to-region (point-min) (point)))) 296 (defun org-graph-edge--in-drawer () 297 "Return nil if point is not in a drawer. 298 Return element at point is in a drawer." 299 (let ((element (org-element-at-point))) 301 (not (memq (org-element-type element) '(drawer property-drawer)))) 302 (setq element (org-element-property :parent element))) 306 (defun org-graph-edge--delete-link (link) 308 If point is in drawer, delete the entire line." 310 (goto-char (org-element-property :begin link)) 311 (if (org-graph-edge--in-drawer) 314 (org-remove-empty-drawer-at (point))) 315 (delete-region (org-element-property :begin link) (org-element-property :end link))))) 318 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 319 ;; EXPERIMENTAL related into drawer 320 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 322 (defun org-graph-edge-related-into-drawer () 323 "Name of the related drawer, as a string, or nil. 324 This is the value of variable 325 `org-graph-edge-related-into-drawer'. However, if the current 326 entry has or inherits a RELATED_INTO_DRAWER property, it will be 327 used instead of the default value." 328 (let ((p (org-entry-get nil "RELATED_INTO_DRAWER" 'inherit t))) 329 (cond ((equal p "nil") nil) 330 ((equal p "t") org-graph-edge-related-drawer-default-name) 332 (p org-graph-edge-related-drawer-default-name) 333 ((stringp org-graph-edge-related-into-drawer) org-graph-edge-related-into-drawer) 334 (org-graph-edge-related-into-drawer org-graph-edge-related-drawer-default-name)))) 336 (defun org-graph-edge-insert-relatedlink (link desc) 337 "LINK DESC related experiment." 338 (if (org-graph-edge-related-into-drawer) 339 (let* ((org-log-into-drawer (org-graph-edge-related-into-drawer)) 340 (beg (org-log-beginning t))) 342 (insert (org-graph-edge-link-prefix)) 343 (org-insert-link nil link desc) 344 (insert (org-graph-edge-link-postfix) "\n") 345 (org-indent-region beg (point))) 346 (insert (org-graph-edge-link-prefix)) 347 (org-insert-link nil link desc) 348 (insert (org-graph-edge-link-postfix)))) 350 (defun org-graph-edge-link-prefix-timestamp () 351 "Return the default prefix string for a backlink. 352 Inactive timestamp formatted according to `org-time-stamp-formats' and 354 (concat (format-time-string (org-time-stamp-format t t) (current-time)) 357 (defun org-graph-edge-quick-insert-drawer-link () 358 "Insert link into drawer regardless of variable `org-graph-edge-related-into-drawer' value." 360 ;; how to handle prefix here? 361 (let ((org-graph-edge-related-into-drawer (or org-graph-edge-related-into-drawer t)) 362 (org-graph-edge-link-prefix 'org-graph-edge-link-prefix-timestamp)) 363 (org-graph-edge-link))) 365 (defun org-graph-edge-quick-insert-inline-link () 366 "Insert inline link regardless of variable `org-graph-edge-related-into-drawer' value." 368 ;; how to handle prefix here? 369 (let ((org-graph-edge-related-into-drawer nil) 370 (org-graph-edge-link-prefix nil)) 371 (org-graph-edge-link))) 373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 374 ;; /EXPERIMENTAL related into drawer 375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 377 (defun org-graph-edge-insert-backlink (link desc) 378 "Insert backlink to LINK with DESC. 379 Where the backlink is placed is determined by the variable `org-graph-edge-backlink-into-drawer'." 380 (let* ((org-log-into-drawer (org-graph-edge-backlink-into-drawer)) 381 (description (org-graph-edge-default-description-formatter link desc)) 382 (beg (org-log-beginning t))) 384 (insert (org-graph-edge-backlink-prefix)) 385 (insert (org-link-make-string link description)) 386 (insert (org-graph-edge-backlink-postfix)) 387 (org-indent-region beg (point)))) 389 (defun org-graph-edge-links-action (marker hooks) 390 "Go to MARKER, run HOOKS and store a link." 391 (with-current-buffer (marker-buffer marker) 394 (widen) ;; buffer could be narrowed 395 (goto-char (marker-position marker)) 397 (call-interactively #'org-store-link) 398 (pop org-stored-links))))) 400 (defun org-graph-edge-link-builder (link) 401 "Format link description for LINK." 402 (let* ((link-ref (car link)) 403 (pre-desc (cadr link)) 404 (description (org-graph-edge-default-description-formatter link-ref pre-desc))) 405 (cons link-ref description))) 407 (defun org-graph-edge--insert-link (target &optional no-forward) 408 "Insert link to marker TARGET at current `point`, and create backlink to here. 409 Only create backlinks in files in `org-mode' or a derived mode, otherwise just 410 act like a normal link. 412 If NO-FORWARD is non-nil skip creating the forward link. Currently 413 only used when converting a link." 414 (let* ((source (point-marker)) 415 (source-link (org-graph-edge-links-action source 'org-graph-edge-pre-link-hook)) 416 (target-link (org-graph-edge-links-action target 'org-graph-edge-pre-backlink-hook)) 417 (source-formatted-link (org-graph-edge-link-builder source-link)) 418 (target-formatted-link (org-graph-edge-link-builder target-link))) 419 (with-current-buffer (marker-buffer target) 422 (widen) ;; buffer could be narrowed 423 (goto-char (marker-position target)) 424 (when (derived-mode-p 'org-mode) 425 (org-graph-edge-insert-backlink (car source-formatted-link) (cdr source-formatted-link)))))) 427 (with-current-buffer (marker-buffer source) 429 (goto-char (marker-position source)) 430 (org-graph-edge-insert-relatedlink (car target-formatted-link) (cdr target-formatted-link))))))) 434 (defun org-graph-edge-convert-link-to-edge (arg) 435 "Convert a normal `org-mode' link at `point' to a graph link, ARG prefix. 436 If variable `org-graph-edge-related-into-drawer' is non-nil move 437 the link into drawer. 439 When called interactively with a `C-u' prefix argument ignore 440 variable `org-graph-edge-related-into-drawer' configuration and 441 do not modify existing link." 443 (let ((from-m (point-marker)) 444 (target (save-window-excursion 445 (with-current-buffer (current-buffer) 449 (org-graph-edge--insert-link target (or arg (not org-graph-edge-related-into-drawer))) 450 (goto-char (marker-position from-m))) 452 (when (and (not arg) (org-graph-edge-related-into-drawer)) 453 (let ((begin (org-element-property :begin (org-element-context))) 454 (end (org-element-property :end (org-element-context)))) 455 (delete-region begin end)))) 458 (defun org-graph-edge-delete-link () 459 "Delete the link at point, and the corresponding reverse link. 460 If no reverse link exists, just delete link at point. 461 This works from either side, and deletes both sides of a link." 463 (save-window-excursion 464 (with-current-buffer (current-buffer) 466 (let ((id (org-id-get (point)))) 468 (let ((link-element (org-graph-edge--find-link id))) 470 (org-graph-edge--delete-link link-element) 471 (message "No backlink found. Deleting active only."))))))) 472 (org-graph-edge--delete-link (org-element-context))) 475 (defun org-graph-edge-store-link (&optional GOTO KEYS) 476 "Store a point to register for use in function `org-graph-edge-insert-link'. 477 This is primarily intended to be called before `org-capture', but 478 could possibly even be used to replace `org-store-link' IF 479 function `org-graph-edge-insert-link' is used to replace 480 `org-insert-link'. This has not been thoroughly tested outside 481 of links to/form org files. GOTO and KEYS are unused." 486 ;; this is a hack. if the point is at the first char of a heading 487 ;; the marker is not updated as expected when text is inserted 488 ;; above the heading. for example a capture template inserted 489 ;; above. that results in the link being to the heading above the 491 (goto-char (line-end-position)) 492 (let ((c1 (make-marker))) 493 (set-marker c1 (point) (current-buffer)) 495 (message "Link copied")))) 497 ;; not sure if this should be autoloaded or left to config? 499 (advice-add 'org-capture :before #'org-graph-edge-store-link) 502 (defun org-graph-edge-insert-link () 503 "Insert a super link from the register." 505 (let* ((target (get-register ?^))) 508 (org-graph-edge--insert-link target) 509 (set-register ?^ nil)) 510 (message "No link to insert!")))) 513 (defun org-graph-edge-link () 514 "Insert a link and add a backlink to the target heading." 516 (org-graph-edge-search-function)) 519 ;; graph.el ends here