├── images ├── org-roam-links.png ├── org-roam-review.png ├── org-roam-search.gif └── org-roam-dblocks.gif ├── .gitignore ├── lisp ├── nursery-pkg.el ├── org-capture-detect.el ├── org-roam-refill-previews.el ├── org-tags-filter.el ├── org-roam-lazy-previews.el ├── org-roam-gc.el ├── org-roam-links.el ├── org-format.el ├── org-roam-consult.el ├── plisty.el ├── ert-bdd.el ├── org-roam-search.el ├── org-roam-slipbox.el ├── timekeep.el ├── org-roam-dblocks.el ├── org-roam-rewrite.el └── org-roam-review.el ├── Readme.org └── LICENSE /images/org-roam-links.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisbarrett/nursery/HEAD/images/org-roam-links.png -------------------------------------------------------------------------------- /images/org-roam-review.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisbarrett/nursery/HEAD/images/org-roam-review.png -------------------------------------------------------------------------------- /images/org-roam-search.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisbarrett/nursery/HEAD/images/org-roam-search.gif -------------------------------------------------------------------------------- /images/org-roam-dblocks.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisbarrett/nursery/HEAD/images/org-roam-dblocks.gif -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Compiled 2 | *.elc 3 | 4 | # Packaging 5 | .cask 6 | 7 | # Backup files 8 | *~ 9 | 10 | # Undo-tree save-files 11 | *.~undo-tree 12 | -------------------------------------------------------------------------------- /lisp/nursery-pkg.el: -------------------------------------------------------------------------------- 1 | (define-package 2 | "nursery" 3 | "0.0.1-pre" 4 | "Unpackage shared Lisp" 5 | '((emacs "27.1") 6 | (async "1.9.5") 7 | (dash "2.19.1") 8 | (f "0.17.2") 9 | (ht "2.4") 10 | (org "9.5.3") 11 | (org-drill "2.7.0") 12 | (org-roam "2.2.2") 13 | (pcre2el "1.8") 14 | (ts "0.3-pre"))) 15 | -------------------------------------------------------------------------------- /lisp/org-capture-detect.el: -------------------------------------------------------------------------------- 1 | ;;; org-capture-detect.el --- Detect whether we're currently in an org-capture context -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2023 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | ;;; Code: 22 | 23 | (require 'org-capture) 24 | 25 | (defvar org-capture-detect--in-org-capture-p nil) 26 | 27 | (defun org-capture-detect () 28 | (or (bound-and-true-p org-capture-mode) 29 | org-capture-detect--in-org-capture-p)) 30 | 31 | (define-advice org-capture (:around (fn &rest args) detect-capture) 32 | (let ((org-capture-detect--in-org-capture-p t)) 33 | (apply fn args))) 34 | 35 | (provide 'org-capture-detect) 36 | 37 | ;;; org-capture-detect.el ends here 38 | -------------------------------------------------------------------------------- /lisp/org-roam-refill-previews.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-refill-previews.el --- Refill org-roam backlink previews -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Refills previews displayed in the org-roam buffer to aid reabability in 23 | ;; narrow window layouts. 24 | 25 | ;; Note that this only works when preview sections are lazily computed, or the 26 | ;; buffer is refreshed. 27 | 28 | ;; Example configuration: 29 | ;; 30 | ;; (use-package org-roam-refill-previews 31 | ;; :after org-roam 32 | ;; :demand t 33 | ;; :config 34 | ;; (add-hook 'org-roam-preview-postprocess-functions #'org-roam-refill-previews)) 35 | 36 | ;;; Code: 37 | 38 | (require 'org) 39 | (require 'org-roam) 40 | (require 'seq) 41 | (require 'subr-x) 42 | 43 | (defgroup org-roam-refill-previews nil 44 | "Fill previews in the org-roam backlinks buffer." 45 | :group 'productivity 46 | :prefix "org-roam-refill-previews-") 47 | 48 | 49 | (defcustom org-roam-refill-previews-justify-p t 50 | "Whether to justify preview text." 51 | :group 'org-roam-refill-previews 52 | :type 'boolean) 53 | 54 | ;;; Code: 55 | (defun org-roam-refill-previews--window-width () 56 | (if-let* ((win (seq-find 57 | (lambda (it) 58 | (with-selected-window it 59 | (derived-mode-p 'org-roam-mode))) 60 | (window-list)))) 61 | (window-width win) 62 | fill-column)) 63 | 64 | (defun org-roam-refill-previews (preview-str) 65 | "Refill PREVIEW-STR to fit the backlinks window. 66 | 67 | Expected to be appended to `org-roam-preview-postprocess-functions'." 68 | (let ((fill-column (org-roam-refill-previews--window-width))) 69 | (with-temp-buffer 70 | (insert (org-fontify-like-in-org-mode preview-str)) 71 | (goto-char (point-max)) 72 | (skip-chars-backward " \t\n") 73 | (while (not (bobp)) 74 | (ignore-errors 75 | (org-fill-element (when org-roam-refill-previews-justify-p 'justify))) 76 | (org-backward-paragraph)) 77 | (buffer-string)))) 78 | 79 | (provide 'org-roam-refill-previews) 80 | 81 | ;;; org-roam-refill-previews.el ends here 82 | -------------------------------------------------------------------------------- /lisp/org-tags-filter.el: -------------------------------------------------------------------------------- 1 | ;;; org-tags-filter.el --- Implements reading & parsing of a tags filter structure. -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Defines a data structure to represent a filter against an org-roam-node's 23 | ;; tags, and provides functions to read and evaluate these filters. 24 | 25 | ;;; Code: 26 | 27 | (require 'dash) 28 | (require 'plisty) 29 | 30 | (plisty-define org-tags-filter 31 | :optional (:required :forbidden)) 32 | 33 | (defun org-tags-filter-parse (input) 34 | ;; (org-tags-filter-parse nil) 35 | ;; (org-tags-filter-parse "") 36 | ;; (org-tags-filter-parse "hello there") 37 | ;; (org-tags-filter-parse "-hello there +obi +wan") 38 | ;; (org-tags-filter-parse '(-hello there "+obi" "+wan")) 39 | (-let* ((tokens 40 | (cond 41 | ((null input) nil) 42 | ((stringp input) 43 | (split-string input " " t)) 44 | ((symbolp input) 45 | (list (symbol-name input))) 46 | ((listp input) 47 | (seq-map (lambda (it) (format "%s" it)) input)) 48 | (t 49 | (error "Cannot parse as note filter: %s" input)))) 50 | ((forbidden required) (-separate (lambda (it) (string-prefix-p "-" it)) tokens))) 51 | (org-tags-filter-create :forbidden (seq-map (lambda (it) (string-remove-prefix "-" it)) 52 | forbidden) 53 | :required (seq-map (lambda (it) (string-remove-prefix "+" it)) 54 | required)))) 55 | 56 | (defun org-tags-filter-pp (tags-filter) 57 | (string-join (append 58 | (seq-map (lambda (it) (concat "-" it)) (org-tags-filter-forbidden tags-filter)) 59 | (org-tags-filter-required tags-filter)) " ")) 60 | 61 | (defvar org-tags-filter-last-value nil) 62 | 63 | (defun org-tags-filter-read (&optional prompt) 64 | (let* ((current-filter (org-tags-filter-pp org-tags-filter-last-value)) 65 | (input (read-string (or prompt "Tags filter (+/-): ") 66 | (unless (string-blank-p current-filter) 67 | (concat current-filter " ")) 68 | 'org-roam-review-tags))) 69 | (org-tags-filter-parse input))) 70 | 71 | (provide 'org-tags-filter) 72 | 73 | ;;; org-tags-filter.el ends here 74 | -------------------------------------------------------------------------------- /lisp/org-roam-lazy-previews.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-lazy-previews.el --- Make previews in org-roam buffer lazy for better performance -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Changes previews in the org-roam buffer to be lazily computed, improving 23 | ;; responsiveness in buffers with many backlinks and reflinks. 24 | ;; 25 | ;; Example configuration: 26 | ;; 27 | ;; (use-package org-roam-lazy-previews 28 | ;; :after org-roam 29 | ;; :demand t) 30 | 31 | ;;; Code: 32 | 33 | (require 'cl-lib) 34 | (require 'magit-section) 35 | (require 'org) 36 | (require 'org-roam) 37 | (require 'subr-x) 38 | 39 | (autoload 'org-roam-review-insert-preview "org-roam-review") 40 | 41 | (defgroup org-roam-lazy-previews nil 42 | "Change org-roam node previews to be lazy for performance." 43 | :group 'productivity 44 | :prefix "org-roam-lazy-previews-") 45 | 46 | (defcustom org-roam-lazy-previews-title-formatter #'org-roam-lazy-previews-custom-title-formatter 47 | "A function to format a node's title for the backlinks buffer. 48 | 49 | It is passed the same arguments as 50 | `org-roam-node-insert-section', and should return a string." 51 | :group 'org-roam-lazy-previews 52 | :type 'function) 53 | 54 | (cl-defun org-roam-lazy-previews-custom-title-formatter (&key source-node properties &allow-other-keys) 55 | (let* ((outline (when-let* ((outline (plist-get properties :outline))) 56 | (mapconcat #'org-link-display-format outline " > "))) 57 | (title (org-roam-node-title source-node))) 58 | (concat (propertize title 'font-lock-face 'org-roam-title) 59 | (when (and outline (not (equal title outline))) 60 | (format " > %s" (propertize outline 'font-lock-face 'org-roam-olp)))))) 61 | 62 | (define-advice org-roam-node-insert-section (:override (&rest args) lazy-previews) 63 | (cl-destructuring-bind (&key source-node point &allow-other-keys) args 64 | (magit-insert-section section (org-roam-node-section (org-roam-node-id source-node) t) 65 | (magit-insert-heading (apply org-roam-lazy-previews-title-formatter args)) 66 | (oset section node source-node) 67 | ;; KLUDGE: Mofified macro-expansion of `magit-insert-section-body' that 68 | ;; avoids unsetting the parent section's keymap. 69 | (oset section washer 70 | (lambda () 71 | (org-roam-review-insert-preview source-node :point point) 72 | (magit-section-maybe-remove-visibility-indicator section)))))) 73 | 74 | (provide 'org-roam-lazy-previews) 75 | 76 | ;;; org-roam-lazy-previews.el ends here 77 | -------------------------------------------------------------------------------- /lisp/org-roam-gc.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-gc.el --- Clean up empty roam files -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; Homepage: https://github.com/chrisbarrett/nursery 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; Simple package that deletes dailies files that don't have anything in them. 25 | 26 | ;; Example configuration: 27 | ;; 28 | ;; (use-package org-roam-gc 29 | ;; :after org-roam 30 | ;; :demand t 31 | ;; :hook (org-mode . org-roam-gc-automatically)) 32 | 33 | ;;; Code: 34 | 35 | (require 'org-roam) 36 | (require 'org-roam-dailies) 37 | 38 | (defconst org-roam-gc-prompt-before-deleting-p nil 39 | "Whether to prompt before removing files when run interactively.") 40 | 41 | (defconst org-roam-gc-debug nil 42 | "Whether to output extra messages for debugging purposes.") 43 | 44 | (defun org-roam-gc--empty-content-p (buf) 45 | (with-current-buffer buf 46 | (save-restriction 47 | (widen) 48 | (save-excursion 49 | (goto-char (point-min)) 50 | (while (equal 'property-drawer (org-element-type (org-element-at-point))) 51 | (org-forward-element)) 52 | (while (and (equal 'keyword (org-element-type (org-element-at-point))) 53 | (ignore-errors 54 | (org-forward-element) 55 | t))) 56 | (or (eobp) 57 | (string-blank-p (buffer-substring (1+ (point)) (point-max)))))))) 58 | 59 | (defun org-roam-gc--empty-file-content-p (file) 60 | (with-temp-buffer 61 | (insert-file-contents file) 62 | (org-roam-gc--empty-content-p (current-buffer)))) 63 | 64 | (defun org-roam-gc-dailies-files () 65 | (require 'org-roam) 66 | (require 'org-roam-dailies) 67 | (let ((path (expand-file-name org-roam-dailies-directory org-roam-directory))) 68 | (seq-filter #'file-regular-p (directory-files path t)))) 69 | 70 | (defmacro org-roam-gc--log (msg &rest args) 71 | `(when org-roam-gc-debug 72 | (message (concat "org-roam-gc: " ,msg) ,@args) 73 | nil)) 74 | 75 | (defun org-roam-gc--file-editing-p (file) 76 | (when-let* ((buf (find-buffer-visiting file))) 77 | (or (buffer-modified-p buf) 78 | (get-buffer-window-list buf)))) 79 | 80 | (defun org-roam-gc--remove-file (file confirm-p) 81 | (let ((file (expand-file-name file))) 82 | (cond 83 | ((org-roam-gc--file-editing-p file) 84 | (org-roam-gc--log "Skipping open file: %s" file)) 85 | 86 | (t 87 | (org-roam-gc--log "Removing file: %s" file) 88 | (with-current-buffer (find-file file) 89 | (when (or (not confirm-p) 90 | (y-or-n-p (format "Delete file `%s'? " (abbreviate-file-name file)))) 91 | (kill-buffer) 92 | (delete-file file))) 93 | t)))) 94 | 95 | (defun org-roam-gc (&optional interactive) 96 | "Delete empty org-roam dailies. 97 | 98 | Optional arg INTERACTIVE determines whether to query before 99 | removing files." 100 | (interactive "p") 101 | (let ((count 102 | (thread-last (org-roam-gc-dailies-files) 103 | (seq-filter #'org-roam-gc--empty-file-content-p) 104 | (seq-filter (lambda (file) 105 | (org-roam-gc--remove-file file (and interactive 106 | org-roam-gc-prompt-before-deleting-p)))) 107 | (length)))) 108 | (cond 109 | (interactive 110 | (message "Deleted %s file%s" count (if (eq 1 count) "" "s"))) 111 | ((< 0 count) 112 | (message "org-roam-gc deleted %s file%s" count (if (eq 1 count) "" "s")))))) 113 | 114 | (defun org-roam-gc--maybe-remove-this-file () 115 | (when-let* ((file (buffer-file-name))) 116 | (cond 117 | ((not (derived-mode-p 'org-mode)) 118 | (org-roam-gc--log "Skipping non-org file: %s" file)) 119 | ((and (org-roam-gc--empty-content-p (current-buffer)) 120 | (org-roam-dailies--daily-note-p)) 121 | (org-roam-gc--log "Removing file: %s" file) 122 | (delete-file (buffer-file-name))) 123 | (t 124 | (org-roam-gc--log "Skipping file: %s" file))))) 125 | 126 | ;;;###autoload 127 | (defun org-roam-gc-automatically () 128 | (add-hook 'kill-buffer-hook #'org-roam-gc--maybe-remove-this-file nil t)) 129 | 130 | (provide 'org-roam-gc) 131 | 132 | ;;; org-roam-gc.el ends here 133 | -------------------------------------------------------------------------------- /lisp/org-roam-links.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-links.el --- Buffer showing links in an org-roam node -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; Homepage: https://github.com/chrisbarrett/nursery 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; org-roam comes with a backlanks buffer that shows previous of other locations 25 | ;; in the Zettlekasten linking here. This is useful for most cases, but it would 26 | ;; be useful to see another level of links deep to find unexpected node 27 | ;; connections. 28 | 29 | ;;; Code: 30 | 31 | (require 'dash) 32 | (require 'org-roam-review) 33 | (require 'plisty) 34 | 35 | (plisty-define org-roam-links-graph 36 | :required (:nodes :tree)) 37 | 38 | (defun org-roam-links--forward-links (node) 39 | (-keep (-compose #'org-roam-node-from-id #'car) 40 | (org-roam-db-query [:select :distinct [dest] :from links :where (= source $s1)] 41 | (org-roam-node-id node)))) 42 | 43 | (defun org-roam-links-graph (node depth) 44 | "Return the linked nodes for NODE, and their links, up to DEPTH." 45 | (when (cl-plusp depth) 46 | (let ((links 47 | (->> (append (org-roam-links--forward-links node) 48 | (seq-map #'org-roam-backlink-source-node (org-roam-backlinks-get node))) 49 | (seq-remove #'org-roam-review-node-ignored-p) 50 | (-uniq))) 51 | (nodes (ht-create)) 52 | (tree (ht-create))) 53 | (dolist (node links) 54 | (let ((id (org-roam-node-id node)) 55 | (children (org-roam-links-graph node (1- depth)))) 56 | (puthash id node nodes) 57 | (-when-let ((&plist :nodes child-nodes) children) 58 | (setq nodes (ht-merge nodes child-nodes))) 59 | (puthash (org-roam-node-id node) (plist-get children :tree) tree))) 60 | (org-roam-links-graph-create :nodes nodes :tree tree)))) 61 | 62 | (defconst org-roam-links-max-title-length 50) 63 | 64 | (defalias 'org-roam-links--graph-sorting 65 | (-compose 'downcase #'org-roam-node-title #'org-roam-node-from-id #'car)) 66 | 67 | ;;;###autoload 68 | (cl-defun org-roam-links (&optional (max-depth 2)) 69 | "Show Evergreen Note links for the current buffer. 70 | 71 | When called interactively, prompt the user for MAX-DEPTH." 72 | (interactive (when current-prefix-arg (list (read-number "Depth: " 2)))) 73 | (-let* ((start-node (or (org-roam-node-at-point) 74 | (let ((node (org-roam-node-read))) 75 | (org-roam-node-visit node) 76 | node))) 77 | (title (org-roam-node-title start-node)) 78 | (short-title (substring title 0 (min (length title) org-roam-links-max-title-length))) 79 | (short-title (if (equal title short-title) title (concat short-title "…"))) 80 | graph) 81 | (display-buffer 82 | (org-roam-review-create-buffer 83 | :title (format "Links for “%s\”" short-title) 84 | :instructions "Below is the graph of links to and from the current node." 85 | :placeholder "No linked nodes" 86 | :buffer-name "*org-roam-links*" 87 | :nodes 88 | (lambda () 89 | (setq graph (org-roam-links-graph start-node max-depth)) 90 | (seq-remove #'org-roam-review-node-ignored-p 91 | (ht-values (org-roam-links-graph-nodes graph)))) 92 | :render 93 | (-lambda ((&plist :root-section)) 94 | (let ((seen-ids (ht-create)) 95 | (nodes (org-roam-links-graph-nodes graph)) 96 | (start-node-id (org-roam-node-id start-node))) 97 | (cl-labels ((render-at-depth 98 | (tree depth) 99 | (let ((sorted-nodes (seq-sort-by 'org-roam-links--graph-sorting #'string< (ht-to-alist tree)))) 100 | (pcase-dolist (`(,id . ,children) sorted-nodes) 101 | (when-let* ((node (ht-get nodes id))) 102 | (magit-insert-section section (org-roam-preview-section) 103 | (oset section parent root-section) 104 | (oset section point (org-roam-node-point node)) 105 | (oset section file (org-roam-node-file node)) 106 | (if (equal id start-node-id) 107 | (magit-cancel-section) 108 | (let* ((seen-p (gethash id seen-ids)) 109 | (heading (funcall org-roam-review-title-formatter node))) 110 | (magit-insert-heading (org-roam-review-indent-string heading depth)) 111 | (unless seen-p 112 | (puthash id t seen-ids) 113 | (when children 114 | (render-at-depth children (1+ depth)))))))))))) 115 | 116 | (render-at-depth (org-roam-links-graph-tree graph) 0)))))))) 117 | 118 | (provide 'org-roam-links) 119 | 120 | ;;; org-roam-links.el ends here 121 | -------------------------------------------------------------------------------- /Readme.org: -------------------------------------------------------------------------------- 1 | #+title: nursery 2 | #+author: Chris Barrett 3 | #+todo: SPIKE(s) INCUBATING(i) | STABLE(t) PUBLISHED(p) 4 | 5 | This is a repository for Emacs Lisp packages that I think could be useful for 6 | friends and coworkers. It's an experimental, low-pressure space for me just to 7 | hack on Lisp with the garage door open. 8 | 9 | If something reaches a stable state I may publish it if there's interest. 10 | 11 | * Curiosities On Show 12 | This repository contains a mix of end-user libraries and supporting libraries. 13 | The interesting stuff is listed below. 14 | 15 | ** INCUBATING [[file:lisp/org-roam-review.el][org-roam-review]] /(incubating)/ 16 | Implements a system for managing [[https://maggieappleton.com/evergreens][Evergreen Notes]] on top of org-roam. Provides a 17 | spaced-repetition system that prompts you to review notes or revisit stubs and 18 | help them grow to maturity. 19 | 20 | #+attr_org: :width 650px 21 | [[file:./images/org-roam-review.png]] 22 | 23 | ** INCUBATING [[file:lisp/org-roam-dblocks.el][org-roam-dblocks]] /(incubating)/ 24 | Add org dynamic blocks that implement "canned searches" for org-roam. You can 25 | search for notes or list backlinks, then do additional filtering based on title 26 | or tags. 27 | 28 | #+attr_org: :width 650px 29 | [[file:images/org-roam-dblocks.gif]] 30 | 31 | ** INCUBATING [[file:lisp/org-roam-search.el][org-roam-search]] /(incubating)/ 32 | Search your org-roam files for a string and display a buffer of results. Results 33 | are shown with collapsible previews, like in the org-roam buffer. 34 | 35 | #+attr_org: :width 650px 36 | [[file:images/org-roam-search.gif]] 37 | 38 | ** INCUBATING [[file:lisp/org-roam-links.el][org-roam-links]] /(incubating)/ 39 | Display a tree of backlinks /and/ forward links up to a configurable depth. Useful 40 | for looking for unexpected connections without busting open a full-fledged graph 41 | UI. Contrasts with the normal org-roam buffer, which only shows backlinks. 42 | 43 | #+attr_org: :width 650px 44 | [[file:images/org-roam-links.png]] 45 | 46 | ** INCUBATING [[file:lisp/org-roam-consult.el][org-roam-consult]] /(incubating)/ 47 | A version of =consult-ripgrep= that shows node titles instead of filenames so you 48 | don't have to guess anymore. 49 | 50 | ** INCUBATING [[file:lisp/org-roam-slipbox.el][org-roam-slipbox]] (/incubating/) 51 | Automatically tag nodes according to the name of the directory they're in, and 52 | easily refile between these directories. 53 | 54 | ** SPIKE [[file:lisp/org-roam-gc.el][org-roam-gc]] /(spike)/ 55 | Automatically delete empty dailies files so they don't build up forever. 56 | 57 | ** SPIKE [[file:lisp/org-roam-rewrite.el][org-roam-rewrite]] /(spike)/ 58 | Commands for renaming nodes, rewriting links and deleting nodes with redirection 59 | so you can refactor notes without leaving broken links. 60 | 61 | ** SPIKE [[file:lisp/timekeep.el][timekeep]] /(spike)/ 62 | Provides a structured way to use org-roam for representing multiple 63 | clients/employers. It provides a simple clocking interface built on org-clock 64 | and provides integrations with org-capture. 65 | 66 | ** SPIKE [[file:lisp/org-roam-refill-previews.el][org-roam-refill-previews]] /(spike)/ 67 | Refill previews in the backlinks buffer so they fit the window. 68 | 69 | ** SPIKE [[file:lisp/org-roam-lazy-previews.el][org-roam-lazy-previews]] /(spike)/ 70 | Compute previews lazily for much better performance in buffers with many 71 | backlinks or reflinks. 72 | 73 | ** SPIKE [[file:lisp/org-format.el][org-format]] (/spike/) 74 | Formatter for org-mode files to ensure consistency. 75 | 76 | ** SPIKE [[file:lisp/ert-bdd.el][ert-bdd]] (/spike/) 77 | BDD-style test syntax for ERT. 78 | 79 | * Installation 80 | Most packages should be manually installable via =package.el=, assuming you have 81 | [[https://melpa.org/#/getting-started][MELPA]] set up. But honestly, you're better off just cloning this repo and putting 82 | its lisp directory in your load path, then installing anything missing. 🤷 83 | 84 | - Clone the repo: 85 | #+begin_src sh 86 | $ git clone git@github.com:chrisbarrett/nursery.git 87 | #+end_src 88 | 89 | - Add to load path: 90 | #+begin_src emacs-lisp 91 | (add-to-list 'load-path "/lisp") 92 | #+end_src 93 | 94 | - load desired features in your =~/.config/emacs/init.el=, e.g.: 95 | #+begin_src emacs-lisp 96 | (use-package org-roam-review 97 | :commands (org-roam-review 98 | org-roam-review-list-by-maturity 99 | org-roam-review-list-recently-added) 100 | 101 | ;; ;; Optional - tag all newly-created notes as seedlings. 102 | ;; :hook (org-roam-capture-new-node . org-roam-review-set-seedling) 103 | 104 | ;; ;; Optional - keybindings for applying Evergreen note properties. 105 | ;; :general 106 | ;; (:keymaps 'org-mode-map 107 | ;; "C-c r r" '(org-roam-review-accept :wk "accept") 108 | ;; "C-c r u" '(org-roam-review-bury :wk "bury") 109 | ;; "C-c r x" '(org-roam-review-set-excluded :wk "set excluded") 110 | ;; "C-c r b" '(org-roam-review-set-budding :wk "set budding") 111 | ;; "C-c r s" '(org-roam-review-set-seedling :wk "set seedling") 112 | ;; "C-c r e" '(org-roam-review-set-evergreen :wk "set evergreen")) 113 | 114 | ;; ;; Optional - bindings for evil-mode compatability. 115 | ;; :general 116 | ;; (:states '(normal) :keymaps 'org-roam-review-mode-map 117 | ;; "TAB" 'magit-section-cycle 118 | ;; "g r" 'org-roam-review-refresh) 119 | ) 120 | 121 | (use-package org-roam-search 122 | :commands (org-roam-search)) 123 | 124 | (use-package org-roam-links 125 | :commands (org-roam-links)) 126 | 127 | (use-package org-roam-dblocks 128 | :hook (org-mode . org-roam-dblocks-autoupdate-mode)) 129 | 130 | (use-package org-roam-rewrite 131 | :commands (org-roam-rewrite-rename 132 | org-roam-rewrite-remove 133 | org-roam-rewrite-inline 134 | org-roam-rewrite-extract)) 135 | 136 | (use-package org-roam-slipbox 137 | :after org-roam 138 | :demand t 139 | :config 140 | (org-roam-slipbox-buffer-identification-mode +1) 141 | (org-roam-slipbox-tag-mode +1)) 142 | #+end_src 143 | -------------------------------------------------------------------------------- /lisp/org-format.el: -------------------------------------------------------------------------------- 1 | ;;; org-format.el --- Auto-format org buffers. -*- lexical-binding: t; -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Adapted from: https://emacs.stackexchange.com/a/28268 6 | 7 | ;; Example configuration: 8 | ;; 9 | ;; (use-package org-format 10 | ;; :hook (org-mode . org-format-on-save-mode)) 11 | 12 | ;;; Code: 13 | 14 | (require 'org) 15 | (require 'org-capture-detect) 16 | (require 'thingatpt) 17 | 18 | (defgroup org-format nil 19 | "Automatically format org buffers on save." 20 | :group 'productivity 21 | :prefix "org-format-") 22 | 23 | (defcustom org-format-blank-lines-before-subheadings 1 24 | "Number of blank lines between a heading and preceding content. 25 | 26 | Only applies to subheadings." 27 | :group 'org-format 28 | :type 'integer) 29 | 30 | (defcustom org-format-blank-lines-before-first-heading 1 31 | "Number of blank lines between a heading and preceding content. 32 | 33 | Only applies to first level-1 heading in the document, and 34 | supercedes the setting for 35 | `org-format-blank-lines-before-level-1-headings'." 36 | :group 'org-format 37 | :type 'integer) 38 | 39 | (defcustom org-format-blank-lines-before-level-1-headings 1 40 | "Number of blank lines between a heading and preceding content. 41 | 42 | Only applies to level-1 headings in the document." 43 | :group 'org-format 44 | :type 'integer) 45 | 46 | (defcustom org-format-blank-lines-before-content 0 47 | "Number of blank lines after the heading line and any property drawers." 48 | :group 'org-format 49 | :type 'integer) 50 | 51 | (defcustom org-format-blank-lines-before-meta 0 52 | "Number of blank lines between headers and subsequent planning & drawers." 53 | :group 'org-format 54 | :type 'integer) 55 | 56 | (defcustom org-format-align-all-tables t 57 | "Whether to align tables on save." 58 | :group 'org-format 59 | :type 'boolean) 60 | 61 | 62 | 63 | (defun org-format--ensure-empty-lines (n) 64 | (save-excursion 65 | (goto-char (line-beginning-position)) 66 | (unless (bobp) 67 | (forward-char -1) 68 | (let ((start (point))) 69 | (when (search-backward-regexp (rx (not (any space "\n")))) 70 | (ignore-errors 71 | (forward-char 1) 72 | (delete-region (point) start)))) 73 | (insert (make-string n ?\n))))) 74 | 75 | (defun org-format--in-archived-heading-p () 76 | (save-excursion 77 | (when (org-before-first-heading-p) 78 | (org-forward-heading-same-level 1)) 79 | (let ((tags (org-get-tags))) 80 | (seq-contains-p tags org-archive-tag)))) 81 | 82 | (defun org-format--delete-blank-lines () 83 | "Modified version of `delete-blank-lines'." 84 | (beginning-of-line) 85 | (when (looking-at "[ \t]*$") 86 | (delete-region (point) 87 | (if (re-search-backward "[^ \t\n]" nil t) 88 | (progn (forward-line 1) (point)) 89 | (point-min)))) 90 | ;; Handle the special case where point is followed by newline and eob. 91 | ;; Delete the line, leaving point at eob. 92 | (when (looking-at "^[ \t]*\n\\'") 93 | (delete-region (point) (point-max)))) 94 | 95 | (defun org-format--headings (scope) 96 | (let ((seen-first-heading-p)) 97 | (org-map-entries (lambda () 98 | ;; Widen so we can see space preceding the current 99 | ;; headline. 100 | (org-with-wide-buffer 101 | (let* ((level (car (org-heading-components))) 102 | (headline-spacing (cond 103 | ((and (equal 1 level) (not seen-first-heading-p)) 104 | (setq seen-first-heading-p t) 105 | org-format-blank-lines-before-first-heading) 106 | ((equal 1 level) 107 | org-format-blank-lines-before-level-1-headings) 108 | (t 109 | org-format-blank-lines-before-subheadings)))) 110 | (org-format--ensure-empty-lines headline-spacing))) 111 | 112 | (unless (and (fboundp 'org-transclusion-within-transclusion-p) 113 | (org-transclusion-within-transclusion-p)) 114 | (forward-line 1) 115 | (org-format--delete-blank-lines) 116 | (org-format--ensure-empty-lines org-format-blank-lines-before-meta) 117 | (org-end-of-meta-data t) 118 | (org-format--ensure-empty-lines org-format-blank-lines-before-content))) 119 | t 120 | scope))) 121 | 122 | (defun org-format--transclusions () 123 | (while (search-forward-regexp (rx bol "#+transclude:") nil t) 124 | (save-excursion 125 | (unless (search-forward ":only-content" (line-end-position) t) 126 | (goto-char (line-beginning-position)) 127 | (org-format--ensure-empty-lines org-format-blank-lines-before-subheadings))))) 128 | 129 | ;;;###autoload 130 | (defun org-format-buffer () 131 | "Format the current `org-mode' buffer." 132 | (interactive) 133 | (unless (org-capture-detect) 134 | (let ((scope (when (org-format--in-archived-heading-p) 135 | ;; archive files can be enormous--just format the heading at 136 | ;; point after archiving. 137 | 'tree))) 138 | (org-with-wide-buffer 139 | 140 | (when org-format-align-all-tables 141 | (org-table-map-tables #'org-table-align t)) 142 | 143 | (org-format--headings scope) 144 | 145 | ;; Clean up trailing whitespace. 146 | (goto-char (point-max)) 147 | (org-format--delete-blank-lines) 148 | 149 | ;; Format transcluded headings as if they were really there. 150 | (goto-char (point-min)) 151 | (org-format--transclusions))))) 152 | 153 | ;; NB: Set this higher than the default to avoid interfering with things like 154 | ;; org-transclusion, etc. 155 | (defvar org-format-on-save-mode-hook-depth 95) 156 | 157 | ;;;###autoload 158 | (define-minor-mode org-format-on-save-mode 159 | "Minor mode to enable formatting on buffer save in `org-mode'." 160 | :lighter nil 161 | (cond 162 | (org-format-on-save-mode 163 | (add-hook 'before-save-hook 'org-format-buffer org-format-on-save-mode-hook-depth t)) 164 | (t 165 | (remove-hook 'before-save-hook 'org-format-buffer t)))) 166 | 167 | (provide 'org-format) 168 | 169 | ;;; org-format.el ends here 170 | -------------------------------------------------------------------------------- /lisp/org-roam-consult.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-consult.el --- Search org-roam nodes with consult -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; This package exposes a command, `org-roam-consult', which is a version 23 | ;; of`consult-ripgrep' that shows the titles of org files rather than their 24 | ;; filepath. This is desirable when searching org-roam files, since filenames 25 | ;; may not correspond to a note's title. 26 | 27 | ;; Example configuration: 28 | ;; 29 | ;; (use-package org-roam-consult 30 | ;; :commands (org-roam-consult)) 31 | 32 | ;;; Code: 33 | 34 | (require 'consult) 35 | (require 'org) 36 | (require 'org-roam) 37 | (require 'memoize) 38 | (require 'pcre2el) 39 | 40 | (defgroup org-roam-consult nil 41 | "Search org-roam nodes with consult." 42 | :group 'productivity 43 | :prefix "org-roam-consult-") 44 | 45 | 46 | (defface org-roam-consult-highlight 47 | `((t (:inherit highlight))) 48 | "Face for hits for a search term." 49 | :group 'org-roam-consult) 50 | 51 | (defvar org-roam-consult-title-search-byte-limit 1024 52 | "The max number of bytes to look at when trying to find a roam node's title.") 53 | 54 | 55 | 56 | (defun org-roam-consult--replace-links-in-string (str) 57 | (save-match-data 58 | (with-temp-buffer 59 | (insert str) 60 | (goto-char (point-min)) 61 | 62 | ;; Replace links with their descriptions. 63 | (save-excursion 64 | (while (search-forward-regexp org-link-bracket-re nil t) 65 | (replace-match (match-string 2)))) 66 | 67 | ;; Best-effort processing for remaining line-wrapped links 68 | (save-excursion 69 | (while (search-forward-regexp (rx "[[" (+? nonl) "][" (group (+? nonl)) (? "]")) nil t) 70 | (replace-match (match-string 1)))) 71 | 72 | (buffer-substring (point-min) (point-max))))) 73 | 74 | (defun org-roam-consult--candidate-group (cand transform) 75 | "Return title for CAND or TRANSFORM the candidate." 76 | (let* ((line (substring cand (1+ (length (get-text-property 0 'consult--grep-file cand))))) 77 | (filename (get-text-property 0 'consult--grep-file cand))) 78 | (if transform 79 | (org-roam-consult--replace-links-in-string line) 80 | (org-roam-consult--format-group-title filename)))) 81 | 82 | (defun org-roam-consult--lookup-title (file) 83 | (with-temp-buffer 84 | (insert-file-contents (expand-file-name file org-roam-directory) nil nil org-roam-consult-title-search-byte-limit) 85 | (goto-char (point-min)) 86 | (if (search-forward-regexp (rx bol "#+title:" (* space) (group (+ any)) eol)) 87 | (match-string 1) 88 | file))) 89 | 90 | (defun org-roam-consult--format-group-title (file) 91 | (let ((title (org-roam-consult--lookup-title file)) 92 | (dir (-some->> (file-name-directory file) (string-remove-prefix "/") (string-remove-suffix "/")))) 93 | (if (or (null dir) (string-blank-p dir)) 94 | title 95 | (format "%s > %s" dir title)))) 96 | 97 | (ignore-errors 98 | (memoize 'org-roam-consult--format-group-title 60)) 99 | 100 | ;; HACK: brutal copy-pasta to tweak two expressions in `consult--grep-format' to 101 | ;; make outputs more readable. 102 | (defun org-roam-consult--format-results (async builder) 103 | "Return ASYNC function highlighting grep match results. 104 | BUILDER is the command argument builder." 105 | (let ((highlight)) 106 | (lambda (action) 107 | (cond 108 | ((stringp action) 109 | (setq highlight (plist-get (funcall builder action) :highlight)) 110 | (funcall async action)) 111 | ((consp action) 112 | (let (result) 113 | (save-match-data 114 | (dolist (str action) 115 | (when (and (string-match consult--grep-match-regexp str) 116 | ;; Filter out empty context lines 117 | (or (/= (aref str (match-beginning 3)) ?-) 118 | (/= (match-end 0) (length str)))) 119 | (let* ((file (match-string 1 str)) 120 | (line (format "%4s" (match-string 2 str))) 121 | (ctx (= (aref str (match-beginning 3)) ?-)) 122 | (sep (if ctx "-" " ")) 123 | (content (substring str (match-end 0))) 124 | (file-len (length file)) 125 | (line-len (length line))) 126 | (when (> (length content) consult-grep-max-columns) 127 | (setq content (substring content 0 consult-grep-max-columns))) 128 | (when highlight 129 | (funcall highlight content)) 130 | (setq str (concat file sep line sep content)) 131 | ;; Store file name in order to avoid allocations in `consult--grep-group' 132 | (add-text-properties 0 file-len `(face consult-file consult--grep-file ,file) str) 133 | (put-text-property (1+ file-len) (+ 1 file-len line-len) 'face 'consult-line-number str) 134 | (when ctx 135 | (add-face-text-property (+ 2 file-len line-len) (length str) 'consult-grep-context 'append str)) 136 | (push str result))))) 137 | (funcall async (nreverse result)))) 138 | (t (funcall async action)))))) 139 | 140 | ;;;###autoload 141 | (defun org-roam-consult (&optional initial) 142 | "Search for regexp with rg in `org-roam-directory' with INITIAL input." 143 | (interactive) 144 | (let* ((default-directory org-roam-directory) 145 | (read-process-output-max (max read-process-output-max (* 1024 1024)))) 146 | (consult--read 147 | (consult--async-command #'consult--ripgrep-builder 148 | (org-roam-consult--format-results #'consult--ripgrep-builder) 149 | :file-handler t) 150 | :prompt "Search Roam: " 151 | :lookup #'consult--lookup-member 152 | :state (consult--grep-state) 153 | :initial (consult--async-split-initial initial) 154 | :add-history (consult--async-split-thingatpt 'symbol) 155 | :require-match t 156 | :category 'consult-grep 157 | :group #'org-roam-consult--candidate-group 158 | :history '(:input consult--grep-history) 159 | :sort nil))) 160 | 161 | (provide 'org-roam-consult) 162 | 163 | ;;; org-roam-consult.el ends here 164 | -------------------------------------------------------------------------------- /lisp/plisty.el: -------------------------------------------------------------------------------- 1 | ;;; plisty.el --- Utilities for working with plists -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; Homepage: https://github.com/chrisbarrett/nursery 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; Dinky little utility library for defining simple schemas for plists. 25 | 26 | ;;; Code: 27 | 28 | (require 'dash) 29 | (require 'cl-lib) 30 | (require 'subr-x) 31 | (require 'ht) 32 | 33 | (defun plisty-keys (plist) 34 | (seq-map #'car (seq-partition plist 2))) 35 | 36 | (defun plisty-pick (key-or-keys plist) 37 | (let ((keys (flatten-list (list key-or-keys))) 38 | (ht (ht-from-plist plist))) 39 | (ht-reject! (lambda (key _v) (not (seq-contains-p keys key))) 40 | ht) 41 | (ht-to-plist ht))) 42 | 43 | (defun plisty-omit (key-or-keys plist) 44 | (let ((keys (flatten-list (list key-or-keys))) 45 | (ht (ht-from-plist plist))) 46 | (ht-reject! (lambda (key _v) (seq-contains-p keys key)) 47 | ht) 48 | (ht-to-plist ht))) 49 | 50 | (defun plisty-map-keys (fn plist) 51 | (let ((pairs (ht-map (lambda (k v) 52 | (list (funcall fn k) v)) 53 | (ht-from-plist plist)))) 54 | (apply 'append pairs))) 55 | 56 | (defun plisty-merge (p1 p2) 57 | "Merge two plists, such that keys in P2 override duplicates in P1." 58 | (let* ((h1 (ht-from-plist p1)) 59 | (h2 (ht-from-plist p2)) 60 | (merged (ht-merge h1 h2))) 61 | (ht-to-plist merged))) 62 | 63 | (defun plisty-p (obj) 64 | "Return t if OBJ is a list and appears to be a plist with keyword keys." 65 | (and (listp obj) 66 | (cl-evenp (length obj)) 67 | (seq-every-p #'keywordp (plisty-keys obj)))) 68 | 69 | (defun plisty-equal (p1 p2) 70 | "Test whether two plists P1 & P2 are structurally equal. 71 | 72 | Values are compared using `equal', except directly nested plists, 73 | which are compared using `plist-equal' recursively." 74 | (cl-assert (plisty-p p1) t) 75 | (cl-assert (plisty-p p2) t) 76 | (catch 'not-equal 77 | (when (equal (length p1) (length p2)) 78 | (dolist (key (plisty-keys p1)) 79 | (let ((v1 (plist-get p1 key)) 80 | (v2 (plist-get p2 key))) 81 | (cond 82 | ((equal v1 v2)) 83 | ((and (plisty-p v1) (plisty-p v2) (plisty-equal v1 v2))) 84 | (t 85 | (throw 'not-equal nil))))) 86 | t))) 87 | 88 | (defun plisty--pred-name-for-type (type) 89 | (intern (format "%s-p" type))) 90 | 91 | (defmacro plisty-define-predicate (type required-keys all-keys) 92 | (cl-assert (symbolp type)) 93 | (cl-assert (listp required-keys)) 94 | (cl-assert (seq-every-p #'keywordp required-keys)) 95 | (cl-assert (seq-every-p #'keywordp all-keys)) 96 | `(defun ,(plisty--pred-name-for-type type) (value &optional strict) 97 | (when (listp value) 98 | (let ((required-keys ',required-keys) 99 | (all-keys ',all-keys)) 100 | (let ((keys (plisty-keys value))) 101 | (and (null (seq-difference required-keys keys)) 102 | (seq-every-p (lambda (key) 103 | (plist-get value key)) 104 | required-keys) 105 | (if strict 106 | (null (seq-difference keys all-keys)) 107 | t))))))) 108 | 109 | (defun plisty--validator-for-type (type) 110 | (intern (format "%s-assert" type))) 111 | 112 | (defmacro plisty-define-validator (type required-keys all-keys) 113 | (cl-assert (symbolp type)) 114 | (cl-assert (listp required-keys)) 115 | (cl-assert (seq-every-p #'keywordp required-keys)) 116 | (cl-assert (seq-every-p #'keywordp all-keys)) 117 | `(defun ,(plisty--validator-for-type type) (value &optional strict) 118 | (cl-assert (listp value) t "Expected a plist" ) 119 | (let ((required-keys ',required-keys) 120 | (all-keys ',all-keys) 121 | (keys (plisty-keys value))) 122 | (cl-assert (null (seq-difference required-keys keys)) t "Missing required keys: %s" (seq-difference required-keys keys)) 123 | (cl-assert (seq-every-p (lambda (key) 124 | (plist-get value key)) 125 | required-keys) t 126 | "Illegal values for required keys: %s" (seq-filter (lambda (key) 127 | (null (plist-get value key))) 128 | required-keys)) 129 | (when strict 130 | (cl-assert (null (seq-difference keys all-keys)) 131 | t 132 | "Unexpected additional keys: %s" 133 | (seq-difference keys all-keys))) 134 | value))) 135 | 136 | (defun plisty--pred-accessor-name (type keyword) 137 | (intern (format "%s-%s" type (string-remove-prefix ":" (symbol-name keyword))))) 138 | 139 | (defmacro plisty-define-getter (type key) 140 | (cl-assert (symbolp type)) 141 | (cl-assert (keywordp key)) 142 | (let ((validator (plisty--validator-for-type type))) 143 | `(defun ,(plisty--pred-accessor-name type key) (,type) 144 | ,(format "Lookup `%s' in a plist of type `%s'." key type) 145 | (when (fboundp ',validator) 146 | (,validator ,type)) 147 | (plist-get ,type ,key)))) 148 | 149 | (defun plisty--format-create-fn-arglist (required optional) 150 | (if (or required optional) 151 | (format "\n\n\(fn &key %s)" 152 | (string-join (append (seq-map (lambda (it) (upcase (string-remove-prefix ":" (symbol-name it)))) required) 153 | (seq-map (lambda (it) (format "[%s]" (upcase (string-remove-prefix ":" (symbol-name it))))) optional)) 154 | " ")) 155 | "")) 156 | 157 | (defmacro plisty-define-create (type required optional) 158 | (cl-assert (symbolp type)) 159 | (cl-assert (listp required)) 160 | (cl-assert (listp optional)) 161 | `(defun ,(intern (format "%s-create" type)) (&rest attrs) 162 | ,(format "Construct a value of type `%s'.%s" 163 | type (plisty--format-create-fn-arglist required optional)) 164 | (,(plisty--validator-for-type type) attrs) 165 | (plisty-pick ',(-union required optional) attrs))) 166 | 167 | (cl-defmacro plisty-define (type &key required optional) 168 | (declare (indent 1)) 169 | (cl-assert (symbolp type)) 170 | (cl-assert (listp required)) 171 | (cl-assert (listp optional)) 172 | (cl-assert (null (seq-intersection required optional))) 173 | (let ((keys (-union required optional))) 174 | `(progn 175 | (plisty-define-predicate ,type ,required ,keys) 176 | (plisty-define-validator ,type ,required ,keys) 177 | (plisty-define-create ,type ,required ,optional) 178 | ,@(seq-map (lambda (it) `(plisty-define-getter ,type ,it)) 179 | keys)))) 180 | 181 | (provide 'plisty) 182 | 183 | ;;; plisty.el ends here 184 | -------------------------------------------------------------------------------- /lisp/ert-bdd.el: -------------------------------------------------------------------------------- 1 | ;;; ert-bbd.el --- BBD-style syntax for ERT -*- lexical-binding: t; -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Provides a nicer syntax for defining tests to run via ERT. It uses similar 6 | ;; BDD-style tests to `buttercup', but since it uses ERT it is better-suited to 7 | ;; interactive development. 8 | ;; 9 | ;; The main functions are: 10 | ;; 11 | ;; - `+describe' which encloses a series of tests, and 12 | ;; 13 | ;; - `+it', which describes a test cases--usually a single assertion using 14 | ;; ert's `should', `should-not', `should-error', etc. 15 | 16 | ;;; Code: 17 | 18 | (require 'cl-lib) 19 | (require 'ert) 20 | 21 | ;;; HACK: Initially define no-op so tests can be defined inline. 22 | 23 | (cl-eval-when (compile load eval) 24 | (unless (macrop 'ert-bdd) 25 | (defmacro ert-bdd (&rest _)))) 26 | 27 | 28 | ;; Since the macro is the primary autoloaded entrypoint, the functions it uses 29 | ;; must be evaluated when byte-compiling. 30 | 31 | (eval-and-compile 32 | (defun ert-bdd--render-test-name (desc-stack) 33 | "Build a test name, as a symbol, from a stack of descriptions. 34 | 35 | DESC-STACK is a list of descriptions collected from surrounding 36 | `+describe' and `+it' forms." 37 | 38 | (when (null desc-stack) 39 | (error "Input must be non-empty")) 40 | 41 | (let* ((ordered (seq-reverse (seq-map (lambda (+it) (format "%s" +it)) desc-stack))) 42 | (transformed (string-replace " " "-" 43 | (string-join ordered "--")))) 44 | (intern transformed))) 45 | 46 | (defun ert-bdd-compile (form &optional inside-it-p) 47 | (cl-labels ((compile (form desc-stack inside-it-p) 48 | (pcase form 49 | 50 | (`(+it ,desc . ,body) 51 | 52 | ;; (when inside-it-p 53 | ;; (error "Cannot write an `+it' inside another `+it'")) 54 | 55 | (cl-assert (or (stringp desc) (symbolp desc))) 56 | 57 | `(ert-deftest ,(ert-bdd--render-test-name (cons desc desc-stack)) () 58 | ,@(seq-map (lambda (it) (compile it nil t)) 59 | body))) 60 | 61 | 62 | (`(+describe ,desc . ,body) 63 | 64 | ;; (when inside-it-p 65 | ;; (error "Cannot write a `+describe' inside an `+it'")) 66 | 67 | (cl-assert (or (stringp desc) (symbolp desc))) 68 | 69 | (let* ((new-stack (cons desc desc-stack)) 70 | (new-body (seq-map (lambda (it) (compile it new-stack nil)) body))) 71 | (pcase new-body 72 | (`() nil) 73 | (`(,x) x) 74 | (xs `(progn ,@xs))))) 75 | 76 | ((pred listp) 77 | (seq-map (lambda (it) (compile it desc-stack inside-it-p)) 78 | form)) 79 | 80 | (_ 81 | form)))) 82 | (compile form nil inside-it-p)))) 83 | 84 | 85 | ;;;###autoload 86 | (defmacro +describe (desc &rest forms) 87 | "Declare a suite of ERT tests using BDD syntax. 88 | 89 | DESC is a description of the test suite--either a symbol or a 90 | string. 91 | 92 | Within FORMS, you may use additional BDD-style `+describe' forms 93 | to build up a hierarchy of tests. Tests within these blocks are 94 | declared using `+it'. 95 | 96 | For example: 97 | 98 | \(+describe \"arithmetic operations\" 99 | (let ((input 100)) 100 | (+describe \"addition\" 101 | (+it \"has an identity (zero)\" 102 | (should (equal (+ 0 input) input)))) 103 | 104 | ;; etc... 105 | )) 106 | 107 | Tests will be excluded from byte-compiled output." 108 | (declare (indent 1)) 109 | (unless load-file-name 110 | (ert-bdd-compile `(+describe ,desc ,@forms)))) 111 | 112 | ;;;###autoload 113 | (defmacro +it (desc &rest forms) 114 | "An ERT test case using BDD syntax. 115 | 116 | DESC is a description of the test case--either a symbol or a 117 | string. It will be concatenated with the descriptions from 118 | enclosing `+describe' forms. 119 | 120 | FORMS are the implementation of the test, and should use ert 121 | macros like `should', `should-not' and `should-error'. 122 | 123 | Tests will be excluded from byte-compiled output." 124 | (declare (indent 1)) 125 | (unless load-file-name 126 | (ert-bdd-compile `(+it ,desc ,@forms) t))) 127 | 128 | 129 | ;;; Tests - nothing like a bit of dogfooding! 130 | 131 | (+describe ert-bdd-render-test-name 132 | 133 | (+describe "empty stack" 134 | (+it "errors" 135 | (should-error (ert-bdd--render-test-name nil)))) 136 | 137 | (+describe "one string element in stack" 138 | (+it "renders that element" 139 | (should (equal (ert-bdd--render-test-name '("input")) 140 | 'input)))) 141 | 142 | (+describe "mix of symbols and strings in stack" 143 | (+it "renders those element" 144 | (should (equal (ert-bdd--render-test-name '("a" b "c")) 145 | 'c--b--a)))) 146 | 147 | (+describe "input sanitisation" 148 | (+it "converts spaces to dashes" 149 | (should (equal (ert-bdd--render-test-name '("a b")) 150 | 'a-b))))) 151 | 152 | 153 | (+describe ert-bdd-compile 154 | 155 | (+describe "input is a `+describe'" 156 | 157 | (+describe "no body forms" 158 | (+it "has no body forms in output" 159 | (should (equal (ert-bdd-compile 160 | '(+describe test-name)) 161 | nil)))) 162 | 163 | (+describe "one body form" 164 | (+it "outputs those forms" 165 | (should (equal (ert-bdd-compile 166 | '(+describe test-name x)) 167 | 'x)))) 168 | 169 | (+describe "many body forms" 170 | (+it "outputs those forms" 171 | (should (equal (ert-bdd-compile 172 | '(+describe test-name x y)) 173 | '(progn x y))))) 174 | 175 | (+describe "input contains no `+it' forms" 176 | (let ((input '(let* ((x 1) 177 | (y 2)) 178 | x 179 | y 180 | (defun foo () 181 | (+ x y))))) 182 | (+it "does not transform its input" 183 | (should (equal (ert-bdd-compile input) input)))))) 184 | 185 | 186 | (+describe "input is an `+it'" 187 | 188 | (+describe "no body forms" 189 | (+it "generated test has no body" 190 | (should (equal (ert-bdd-compile 191 | '(+it test-name)) 192 | '(ert-deftest test-name ()))))) 193 | 194 | (+describe "one body form" 195 | (+it "generated test has that form as its body" 196 | (should (equal (ert-bdd-compile 197 | '(+it test-name x)) 198 | '(ert-deftest test-name () 199 | x))))) 200 | 201 | (+describe "many body forms" 202 | (+it "generated test has those body forms" 203 | (should (equal (ert-bdd-compile 204 | '(+it test-name x y)) 205 | '(ert-deftest test-name () 206 | x 207 | y))))) 208 | 209 | (+describe "test name is a symbol" 210 | (+it "produces the expected test" 211 | (should (equal 212 | (ert-bdd-compile 213 | '(+it test-name 214 | (should (equal 1 2)))) 215 | '(ert-deftest test-name () 216 | (should (equal 1 2))))))) 217 | 218 | (+describe "test name is a string" 219 | (+it "produces the expected test" 220 | (should (equal 221 | (ert-bdd-compile 222 | '(+it "test name" 223 | (should (equal 1 2)))) 224 | '(ert-deftest test-name () 225 | (should (equal 1 2)))))))) 226 | 227 | 228 | (+describe "an +it is wrapped in another form" 229 | (+it "is still macro-expanded" 230 | (should (equal 231 | 232 | (ert-bdd-compile 233 | '(let ((x 1)) 234 | (+it "test name" 235 | (should (= x 1))))) 236 | 237 | 238 | '(let ((x 1)) 239 | (ert-deftest test-name () 240 | (should (= x 1))))))))) 241 | 242 | 243 | (provide 'ert-bdd) 244 | 245 | ;;; ert-bdd.el ends here 246 | -------------------------------------------------------------------------------- /lisp/org-roam-search.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-search.el --- A search interface that works better with org-roam -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; Homepage: https://github.com/chrisbarrett/nursery 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; Org-roam works best when your nodes are divided into many files, but this 25 | ;; makes the org-search functionality unsuitable. ripgrep does a better job, but 26 | ;; has the problem that it shows the raw filenames instead of the node title. 27 | 28 | ;; This implementation of search aims to surface matched text along with the 29 | ;; title of the relevant node. 30 | 31 | ;; This package exposes two commands, `org-roam-search' and 32 | ;; `org-roam-search-tags', that search your org-roam nodes with ripgrep and 33 | ;; display a buffer of matching nodes. 34 | 35 | ;; Example configuration: 36 | ;; 37 | ;; (use-package org-roam-search 38 | ;; :commands (org-roam-search) 39 | ;; :general 40 | ;; (:keymaps 'org-roam-mode-map :states '(normal motion) 41 | ;; "s" 'org-roam-search)) 42 | 43 | ;;; Code: 44 | 45 | (require 'async) 46 | (require 'dash) 47 | (require 'magit-diff) 48 | (require 'org-roam) 49 | (require 'org-roam-review) 50 | (require 'pcre2el) 51 | 52 | (defgroup org-roam-search nil 53 | "Node search interface for org-roam." 54 | :group 'productivity 55 | :prefix "org-roam-search-") 56 | 57 | (defcustom org-roam-search-ripgrep-program "rg" 58 | "Path to the ripgrep program for searching notes." 59 | :group 'org-roam-search 60 | :type 'string) 61 | 62 | (defcustom org-roam-search-ripgrep-extra-flags '("--follow" "--smart-case" "--no-messages") 63 | "Extra flags to apply when searching via ripgrep." 64 | :group 'org-roam-search 65 | :type '(list string)) 66 | 67 | (defcustom org-roam-search-ignored-tags nil 68 | "A list of tags for nodes that should never be included in search results. 69 | 70 | For instance, you might want never want to see dailies in your 71 | search results. If you tagged them with a tag in this list they 72 | would be excluded." 73 | :group 'org-roam-search 74 | :type '(list string)) 75 | 76 | (defvar org-roam-search-buffer-name "*org-roam-search*") 77 | (defvar org-roam-search-tags-buffer-name "*org-roam-search-tags*") 78 | 79 | (defface org-roam-search-highlight 80 | '((t 81 | (:inherit magit-diff-added-highlight))) 82 | "Face for highlighted results in the search buffer." 83 | :group 'org-roam-search) 84 | 85 | (defface org-roam-search-query 86 | '((t 87 | (:inherit font-lock-string-face))) 88 | "Face for the search query in the header line." 89 | :group 'org-roam-search) 90 | 91 | 92 | 93 | 94 | (defun org-roam-search--highlight-matches (regexp) 95 | (save-excursion 96 | (goto-char (point-min)) 97 | (save-match-data 98 | (let ((transpiled-regexp (pcre-to-elisp regexp))) 99 | (while (search-forward-regexp transpiled-regexp nil t) 100 | (unless (seq-intersection (face-at-point nil t) '(magit-section-heading org-roam-review-instructions)) 101 | (let ((overlay (make-overlay (let ((pt (match-beginning 0))) 102 | (goto-char pt) 103 | (min pt (or (car (save-match-data (bounds-of-thing-at-point 'word))) 104 | (line-end-position)))) 105 | (let ((pt (match-end 0))) 106 | (goto-char pt) 107 | (max pt (or (cdr (save-match-data (bounds-of-thing-at-point 'word))) 108 | (line-beginning-position))))))) 109 | (overlay-put overlay 'face 'org-roam-search-highlight)))))))) 110 | 111 | (defun org-roam-search--match-previews (search-regexp node) 112 | (let ((hits)) 113 | (save-match-data 114 | (with-temp-buffer 115 | (insert-file-contents (org-roam-node-file node)) 116 | (let ((org-inhibit-startup t)) 117 | (org-mode)) 118 | (goto-char (point-min)) 119 | (org-roam-end-of-meta-data t) 120 | (while (search-forward-regexp search-regexp nil t) 121 | (let ((hit (list :pos (match-beginning 0) 122 | :olp (ignore-errors (org-get-outline-path t t)) 123 | :preview 124 | ;; Extracted from implementation of 125 | ;; `org-roam-preview-get-contents' 126 | (let ((s (funcall org-roam-preview-function))) 127 | (dolist (fn org-roam-preview-postprocess-functions) 128 | (setq s (funcall fn s))) 129 | (org-roam-fontify-like-in-org-mode s))))) 130 | (push hit hits))))) 131 | (->> (nreverse hits) 132 | ;; Take the first hit from each outline 133 | (seq-group-by (lambda (it) (plist-get it :olp))) 134 | (ht-from-alist) 135 | (ht-map (lambda (_key values) (car values)))))) 136 | 137 | (defun org-roam-search-make-insert-preview-fn (search-regexp) 138 | (lambda (node) 139 | (let ((hits-in-file (org-roam-search--match-previews search-regexp node))) 140 | (cond 141 | (hits-in-file 142 | (--each-indexed hits-in-file 143 | (magit-insert-section section (org-roam-preview-section) 144 | (-let [(&plist :olp :preview :pos) it] 145 | (when (and olp (< 1 (length olp))) 146 | (let ((start (point)) 147 | (heading (propertize (string-join olp " > ") 'face 'org-roam-title))) 148 | (insert heading) 149 | (fill-region start (point)) 150 | (insert "\n"))) 151 | (insert preview) 152 | (oset section file (org-roam-node-file node)) 153 | (oset section point pos) 154 | (insert "\n\n"))))) 155 | ((string-match-p search-regexp (org-roam-node-title node)) 156 | (insert (propertize "(Matched title)" 'font-lock-face 'font-lock-comment-face)) 157 | (insert "\n\n")) 158 | (t 159 | (magit-cancel-section)))))) 160 | 161 | (defvar org-roam-search-view-query-history nil) 162 | 163 | (defun org-roam-search--ripgrep-for-nodes (query) 164 | (let ((reporter (make-progress-reporter "Searching nodes")) 165 | (files (ht-create)) 166 | (ripgrep-args (append org-roam-search-ripgrep-extra-flags (list "--json" query org-roam-directory)))) 167 | (async-wait 168 | (apply 'async-start-process "ripgrep" org-roam-search-ripgrep-program 169 | (lambda (_) 170 | (goto-char (point-min)) 171 | (while (not (eobp)) 172 | (progress-reporter-update reporter) 173 | (-when-let* ((line (buffer-substring (line-beginning-position) (line-end-position))) 174 | 175 | ((parsed &as &plist :type) 176 | (json-parse-string line :object-type 'plist)) 177 | 178 | ((&plist :data (&plist :path (&plist :text file) :absolute_offset pos)) 179 | (when (equal "match" type) 180 | parsed)) 181 | (file (expand-file-name file org-roam-directory))) 182 | (puthash file file files)) 183 | (forward-line))) 184 | ripgrep-args)) 185 | (progress-reporter-done reporter) 186 | (seq-filter (lambda (node) 187 | (and (ht-get files (org-roam-node-file node)) 188 | (null (seq-intersection (org-roam-node-tags node) 189 | org-roam-search-ignored-tags)))) 190 | (org-roam-node-list)))) 191 | 192 | ;;;###autoload 193 | (defun org-roam-search (query) 194 | "Search `org-roam-directory' for nodes matching a query. 195 | 196 | QUERY is a PRCE regexp string that will be passed to ripgrep." 197 | (interactive (list 198 | (let* ((default (car org-roam-search-view-query-history)) 199 | (prompt (format "Search Roam%s: " (if default (format " (default \"%s\")" default) ""))) 200 | (input (string-trim (read-string prompt nil 'org-roam-search-view-query-history org-roam-search-view-query-history)))) 201 | (if (and (string-match-p (rx "|") input) 202 | (not (string-prefix-p "(" input))) 203 | (format "(%s)" input) 204 | input)))) 205 | (let ((nodes (org-roam-search--ripgrep-for-nodes query))) 206 | (display-buffer 207 | (org-roam-review-create-buffer 208 | :title (concat "Search Results: " (propertize query 'face 'org-roam-search-query)) 209 | :placeholder "No search results" 210 | :buffer-name org-roam-search-buffer-name 211 | :nodes 212 | (lambda () 213 | (seq-remove #'org-roam-review-node-ignored-p nodes)) 214 | :render 215 | (-lambda ((&plist :nodes :placeholder :root-section)) 216 | (cond 217 | ((null nodes) 218 | (insert placeholder) 219 | (newline)) 220 | (t 221 | (pcase-dolist (`(,_file . ,group) (seq-group-by #'org-roam-node-file nodes)) 222 | (when-let* ((top-node (-max-by (-on #'< #'org-roam-node-level) 223 | group) ) 224 | (node-id (org-roam-node-id top-node))) 225 | (magit-insert-section section (org-roam-node-section node-id t) 226 | (magit-insert-heading 227 | (concat (funcall org-roam-review-title-formatter top-node) 228 | " " 229 | (when-let* ((mat (org-roam-review-node-maturity top-node))) 230 | (alist-get mat org-roam-review-maturity-emoji-alist nil nil #'equal)))) 231 | (oset section parent root-section) 232 | (oset section node top-node) 233 | (oset section washer 234 | (lambda () 235 | (org-roam-review-insert-preview top-node) 236 | (org-roam-search--highlight-matches query) 237 | (magit-section-maybe-remove-visibility-indicator section)))))) 238 | (org-roam-search--highlight-matches query)))))))) 239 | 240 | ;;;###autoload 241 | (defun org-roam-search-tags (query) 242 | "Search `org-roam-directory' for nodes matching a tags query. 243 | 244 | QUERY is an `org-tags-filter'." 245 | (interactive (list (org-tags-filter-read "Search by tags filter (+/-): "))) 246 | (org-roam-review-modify-tags query t) 247 | (display-buffer 248 | (org-roam-review-create-buffer 249 | :title "Tag Search Results" 250 | :instructions "The list below contains nodes matching the given tags." 251 | :placeholder "No search results" 252 | :buffer-name org-roam-search-tags-buffer-name 253 | :sort #'org-roam-review-sort-by-title-case-insensitive))) 254 | 255 | (provide 'org-roam-search) 256 | 257 | ;;; org-roam-search.el ends here 258 | -------------------------------------------------------------------------------- /lisp/org-roam-slipbox.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-slipbox.el --- Teach org-roam how to handle multiple slipboxes -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; A 'slipbox' is a distinct folder of notes related to a specific topic or 23 | ;; context that should be differentiated from other notes in your Zettelkasten. 24 | ;; Broadly speaking, they represent mutually exclusive categories of notes. 25 | ;; 26 | ;; For example, you might maintain separate slipboxes for Evergreen Notes, notes 27 | ;; to do with your job or specific clients, and your dailies. 28 | 29 | ;; When searching notes, or using dynamic blocks to build lists of notes[1], 30 | ;; it's useful to have a tag corresponding to the slipbox to enable filtering. 31 | ;; This package hooks into org-roam's indexing so that a slipbox tag is 32 | ;; automatically applied when the note is indexed, saving you from having to add 33 | ;; the tag yourself. It also provides a function to 'refile' from one slipbox to 34 | ;; another[2] in a structured way. 35 | ;; 36 | ;; The slipbox tag is computed based on the name of the folder: 37 | ;; 38 | ;; `org-roam-directory' -> tagged with `org-roam-slipbox-default' 39 | ;; | 40 | ;; |--- dailies -> tagged with :dailies: 41 | ;; |--- outlines -> tagged with :outlines: 42 | ;; \--- work -> tagged with :work: 43 | ;; 44 | ;; [1]: see `org-roam-dblocks' 45 | ;; 46 | ;; [2]: see `org-roam-slipbox-refile'. 47 | ;; 48 | 49 | ;;; Installation: 50 | 51 | ;; (use-package org-roam-slipbox 52 | ;; :after org-roam 53 | ;; :demand t 54 | ;; :config 55 | ;; (org-roam-slipbox-buffer-identification-mode +1) 56 | ;; (org-roam-slipbox-tag-mode +1)) 57 | ;; 58 | ;; After enabling the mode, run `C-u M-x org-roam-db-sync' to rebuild your notes 59 | ;; index. Thereafter, the slipbox tag will automatically be applied at 60 | ;; indexing-time. 61 | 62 | ;;; Code: 63 | 64 | (require 'f) 65 | (require 'magit) 66 | (require 'org-capture-detect) 67 | (require 'org-roam) 68 | (require 'org-roam-review) 69 | (require 'org-roam-rewrite) 70 | 71 | (defgroup org-roam-slipbox nil 72 | "Teach org-roam how to interpret multiple slipboxes." 73 | :group 'productivity 74 | :prefix "org-roam-slipbox-") 75 | 76 | (defcustom org-roam-slipbox-default "notes" 77 | "A 'default' slipbox tag to apply for nodes not in a slipbox. 78 | 79 | Nodes at the top-level of the org-roam directory will have this 80 | tag applied." 81 | :group 'org-roam-slipbox 82 | :type '(choice (string :tag "Tag") 83 | (const :tag "None" nil))) 84 | 85 | (defcustom org-roam-slipbox-after-refile-hook nil 86 | "Hook run after a node is refiled via `org-roam-slipbox-refile'." 87 | :group 'org-roam-slipbox 88 | :type 'hook) 89 | 90 | (defcustom org-roam-slipbox-mode-line-separator " > " 91 | "The separator string between the slipbox name and the node title." 92 | :group 'org-roam-slipbox 93 | :type 'string) 94 | 95 | (defface org-roam-slipbox-name 96 | '((t 97 | (:inherit font-lock-string-face))) 98 | "Face for references to slipboxes." 99 | :group 'org-roam-slipbox) 100 | 101 | (defface org-roam-slipbox-mode-line-separator 102 | '((t 103 | (:inherit comment))) 104 | "Face for the separator in the mode line string." 105 | :group 'org-roam-slipbox) 106 | 107 | (defcustom org-roam-slipbox-use-git-p t 108 | "Whether to update git when modifying nodes in slipboxes." 109 | :group 'org-roam-slipbox 110 | :type 'boolean) 111 | 112 | 113 | 114 | (defun org-roam-slipbox--sanitize-tag (str) 115 | (s-replace-regexp (rx (not (any alnum "_@#%"))) "_" str)) 116 | 117 | (defun org-roam-slipbox-from-file (file) 118 | (condition-case nil 119 | (let ((dir (directory-file-name (file-name-directory file)))) 120 | (if (equal dir org-roam-directory) 121 | org-roam-slipbox-default 122 | (org-roam-slipbox--sanitize-tag (file-name-nondirectory dir)))) 123 | (error org-roam-slipbox-default))) 124 | 125 | (cl-defmethod org-roam-node-slipbox ((node org-roam-node)) 126 | "Return the slipbox a NODE belongs to. 127 | 128 | See also: `org-roam-slipbox-default'." 129 | (org-roam-slipbox-from-file 130 | ;; HACK: Work around org-roam-node-file being 131 | ;; nil during capture sequence. 132 | (if org-roam-capture--node 133 | (expand-file-name ".placeholder") 134 | (org-roam-node-file node)))) 135 | 136 | ;; NOTE: Cannot use autoload magic comment directly on a defmethod. 137 | 138 | ;;;###autoload 139 | (autoload 'org-roam-node-slipbox "org-roam-slipbox") 140 | 141 | (defun org-roam-slipbox--rename-file-without-git (from to) 142 | "Move file FROM to TO, updating the file's buffer if open. 143 | 144 | Adapted from `magit-file-rename', but with the git actions stripped out." 145 | (rename-file from to) 146 | (when-let* ((buf (get-file-buffer from))) 147 | (with-current-buffer buf 148 | (let ((buffer-read-only buffer-read-only)) 149 | (set-visited-file-name to nil t))))) 150 | 151 | (defun org-roam-slipbox--rename-file-with-magit (from to) 152 | (let ((repo-a (magit-toplevel (file-name-directory from))) 153 | (repo-b (magit-toplevel (file-name-directory to)))) 154 | 155 | ;; Ensure the file is tracked by git. 156 | (magit-call-git "add" (magit-convert-filename-for-git from)) 157 | 158 | (if (equal repo-a repo-b) 159 | (magit-file-rename from to) 160 | (let ((default-directory repo-b)) 161 | (org-roam-slipbox--rename-file-without-git from to) 162 | (magit-call-git "add" (magit-convert-filename-for-git to)))))) 163 | 164 | (defun org-roam-slipbox--read (&optional current-slipbox) 165 | (let ((slipboxes (seq-difference (f-directories org-roam-directory) 166 | (list current-slipbox)))) 167 | (completing-read "Slipbox: " slipboxes nil t))) 168 | 169 | ;;;###autoload 170 | (defun org-roam-slipbox-refile (node slipbox) 171 | "Move NODE into SLIPBOX." 172 | (interactive (let* ((node (org-roam-node-at-point t)) 173 | (current-slipbox (org-roam-node-slipbox node))) 174 | (list node (org-roam-slipbox--read current-slipbox)))) 175 | 176 | (let ((current-slipbox (org-roam-node-slipbox node)) 177 | dest) 178 | (cond 179 | ((zerop (org-roam-node-level node)) 180 | (let ((file (org-roam-node-file node))) 181 | (setq dest (expand-file-name (file-name-concat slipbox (file-name-nondirectory file)) 182 | org-roam-directory)) 183 | (if org-roam-slipbox-use-git-p 184 | (org-roam-slipbox--rename-file-with-magit file dest) 185 | (org-roam-slipbox--rename-file-without-git file dest)) 186 | (org-roam-db-sync))) 187 | (t 188 | (let ((new-file (file-name-nondirectory (org-roam-rewrite--new-filename-from-capture-template node)))) 189 | (setq dest (file-name-concat org-roam-directory slipbox new-file)) 190 | (org-roam-rewrite-extract node dest)))) 191 | 192 | (run-hooks 'org-roam-slipbox-after-refile-hook) 193 | 194 | (message (concat "Refiled from " 195 | (propertize current-slipbox 'face 'org-roam-slipbox-name) 196 | " to " 197 | (propertize slipbox 'face 'org-roam-slipbox-name))))) 198 | 199 | (defun org-roam-slipbox--ad-append-slipbox-tag (&optional _tags-only) 200 | (when-let* ((slipbox (ignore-errors (org-roam-slipbox-from-file (buffer-file-name))))) 201 | (add-to-list 'org-file-tags 202 | ;; File-level properties should always have this text property, 203 | ;; otherwise org shows the tag in the agenda, for instance. 204 | (propertize slipbox 'inherited t)))) 205 | 206 | ;;;###autoload 207 | (define-minor-mode org-roam-slipbox-tag-mode 208 | "Automatically add a node's slipbox as a tag." 209 | :global t 210 | (cond 211 | (org-roam-slipbox-tag-mode 212 | (advice-add 'org-set-regexps-and-options :after #'org-roam-slipbox--ad-append-slipbox-tag)) 213 | (t 214 | (advice-remove 'org-set-regexps-and-options #'org-roam-slipbox--ad-append-slipbox-tag)))) 215 | 216 | 217 | 218 | (defvar-local org-roam-slipbox--original-buffer-identification nil 219 | "Stores the original value of `mode-line-buffer-identification'. 220 | 221 | This means titles can be restored if 222 | `org-roam-slipbox-buffer-identification-mode' is toggled.") 223 | 224 | ;;;###autoload 225 | (define-minor-mode org-roam-slipbox-buffer-identification-mode 226 | "Display the slipbox and node title as the buffer name." 227 | :global t 228 | (cond 229 | (org-roam-slipbox-buffer-identification-mode 230 | (add-hook 'org-mode-hook #'org-roam-slipbox--set-up-buffer-identification-mode) 231 | (add-hook 'org-roam-rewrite-node-renamed-hook #'org-roam-slipbox-update-buffer-identification) 232 | (add-hook 'org-roam-slipbox-after-refile-hook #'org-roam-slipbox-update-buffer-identification) 233 | 234 | (when (derived-mode-p 'org-mode) 235 | (org-roam-slipbox--set-up-buffer-identification-mode))) 236 | (t 237 | (remove-hook 'org-mode-hook #'org-roam-slipbox--set-up-buffer-identification-mode) 238 | (remove-hook 'org-roam-rewrite-node-renamed-hook #'org-roam-slipbox-update-buffer-identification) 239 | (remove-hook 'org-roam-slipbox-after-refile-hook #'org-roam-slipbox-update-buffer-identification) 240 | 241 | ;; Restore default buffer identification settings. 242 | (dolist (buf (seq-filter (lambda (it) (with-current-buffer it (derived-mode-p 'org-mode))) 243 | (buffer-list))) 244 | (with-current-buffer buf 245 | (org-roam-slipbox-update-buffer-identification)))))) 246 | 247 | (defun org-roam-slipbox--set-up-buffer-identification-mode () 248 | ;; Save the default buffer identification settings. 249 | (setq org-roam-slipbox--original-buffer-identification mode-line-buffer-identification) 250 | 251 | (unless (or org-inhibit-startup (org-capture-detect)) 252 | (org-roam-slipbox-update-buffer-identification) 253 | (add-hook 'after-save-hook #'org-roam-slipbox-update-buffer-identification nil t))) 254 | 255 | (defun org-roam-slipbox-update-buffer-identification () 256 | (cond 257 | (org-roam-slipbox-buffer-identification-mode 258 | (when-let* ((node 259 | (ignore-errors (save-excursion 260 | (goto-char (point-min)) 261 | (org-roam-node-at-point))))) 262 | (setq-local mode-line-buffer-identification 263 | (concat (propertize (org-roam-node-slipbox node) 'face 'org-roam-slipbox-name) 264 | (propertize org-roam-slipbox-mode-line-separator 'face 'org-roam-slipbox-mode-line-separator) 265 | (propertize (org-roam-node-title node) 'face 'mode-line-highlight 'help-echo (buffer-file-name)))))) 266 | (t 267 | (setq-local mode-line-buffer-identification org-roam-slipbox--original-buffer-identification)))) 268 | 269 | 270 | 271 | ;;;###autoload 272 | (defun org-roam-slipbox-list-notes (slipbox) 273 | "List nodes belonging to SLIPBOX." 274 | (interactive (list (org-roam-slipbox--read))) 275 | (display-buffer 276 | (org-roam-review-create-buffer 277 | :title (concat "Notes for slipbox: " (propertize slipbox 'face 'org-roam-slipbox-name)) 278 | :instructions "The nodes below are sorted by slipbox" 279 | :group-on (lambda (it) 280 | (or (org-roam-review--maturity-header it) 281 | (cons "Others" 4))) 282 | :nodes 283 | (lambda () 284 | (seq-filter (lambda (node) 285 | (seq-contains-p (org-roam-node-tags node) slipbox)) 286 | (org-roam-node-list))) 287 | :sort #'org-roam-review-sort-by-title-case-insensitive))) 288 | 289 | (provide 'org-roam-slipbox) 290 | 291 | ;;; org-roam-slipbox.el ends here 292 | -------------------------------------------------------------------------------- /lisp/timekeep.el: -------------------------------------------------------------------------------- 1 | ;;; timekeep.el --- Clocking workflow based on org-roam-nodes -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; This package provides a way of using org-roam nodes to represent clients or 23 | ;; employers. I developed it because I wanted a good way to capture time spent 24 | ;; on tasks for contract work across multiple clients. I also wanted capture 25 | ;; templates for filing into clocktrees for each client, to make weekly reviews 26 | ;; easy. 27 | 28 | ;; The big idea is to use an org-roam node for each client, and decorate it with 29 | ;; properties to indicate it denotes a client or employer. Then, integrate 30 | ;; org-clock and org-capture with this view of the world by: 31 | ;; 32 | ;; 1. providing a smooth clocking interface modelled around punching 33 | ;; in/out.[fn:1] 34 | ;; 35 | ;; 2. exposing functions for use in capture templates, making it easy to capture 36 | ;; into a clocktree or the toplevel of the current client's file. 37 | 38 | ;; Any roam node with a property whose name starts with "TIMEKEEP" will be 39 | ;; considered a timekeep "target". Once you have a few nodes defined as targets, 40 | ;; you can switch between them with `C-u timekeep-visit-node'. Without the 41 | ;; prefix argument this command just jumps to the node selected most recently 42 | ;; from that list. 43 | 44 | ;; Aside from visiting your target buffers, the main commands you'd use are 45 | ;; `timekeep-start' and `timekeep-stop', which provide a simple punch-in/out 46 | ;; interface for a managing a working session. Punching in will create a 47 | ;; clocktree in the target roam node, and by default will clock in there. 48 | 49 | ;; While a timekeep clocking session is active, clocking commands will behave 50 | ;; differently; clocking out will search upward for an unfinished parent task to 51 | ;; clock into. If this search fails, the clocktree is clocked into as a 52 | ;; fallback. This allows you to account for time where you're not doing 53 | ;; organisational work, answering Slack & emails, etc, rather than working on 54 | ;; specific tasks. 55 | 56 | ;; If you want to take a break you run `timekeep-stop' to punch out and suspend 57 | ;; the current clock. When you get back, `timekeep-start' will resume where you 58 | ;; left off. 59 | 60 | ;; Example configuration: 61 | ;; 62 | ;; (use-package timekeep 63 | ;; :commands (timekeep-start 64 | ;; timekeep-stop 65 | ;; timekeep-mode 66 | ;; timekeep-choose-target 67 | ;; timekeep-visit-node) 68 | ;; :after org 69 | ;; :demand t 70 | ;; :general ("" (general-predicate-dispatch 'timekeep-start 71 | ;; (and (fboundp 'org-clocking-p) (org-clocking-p)) 'timekeep-stop)) 72 | ;; :config 73 | ;; (timekeep-mode +1)) 74 | 75 | ;; For org-capture integration, you can use `timekeep-capture-to-clocktree' and 76 | ;; `timekeep-capture-to-toplevel' as location-finding functions in your 77 | ;; templates. 78 | 79 | ;; 80 | ;; [fn:1] The approach here takes inspiration from the punch-in/punch-out 81 | ;; workflow outlined by Bernt Hansen. See: 82 | ;; http://doc.norang.ca/org-mode.html#Clocking 83 | 84 | 85 | ;;; Code: 86 | 87 | (require 'org-agenda) 88 | (require 'org-capture) 89 | (require 'org-clock) 90 | (require 'org-roam-node) 91 | (require 'persist) 92 | 93 | (defgroup timekeep nil 94 | "Functions for managing client timekeeping with org-clock." 95 | :group 'productivity 96 | :prefix "timekeep-") 97 | 98 | (defcustom timekeep-default-headline-name "Planning & Meetings" 99 | "The name of the heading to clock in to if not working on a specific task. 100 | 101 | The heading will be created if needed." 102 | :group 'timekeep 103 | :type 'string) 104 | 105 | (defcustom timekeep-fallback-work-tag "work" 106 | "The tag to return from `timekeep-work-tag' as a fallback. 107 | 108 | Will be used if: 109 | 110 | - there is no current target, or 111 | 112 | - the current target does not have a TIMEKEEP_TAG or CATEGORY 113 | property." 114 | :group 'timekeep 115 | :type 'string) 116 | 117 | (defcustom timekeep-agenda-should-update-hook nil 118 | "Hook run when a clocking change should update the agenda." 119 | :group 'timekeep 120 | :type 'hook) 121 | 122 | (defcustom timekeep-punched-in-hook nil 123 | "Hook run after punching in." 124 | :group 'timekeep 125 | :type 'hook) 126 | 127 | (defcustom timekeep-punched-out-hook nil 128 | "Hook run after punching out." 129 | :group 'timekeep 130 | :type 'hook) 131 | 132 | (defcustom timekeep-node-to-name-function #'org-roam-node-title 133 | "Function taking an `org-roam-node' and returning a company or cilent's name." 134 | :group 'timekeep 135 | :type 'function) 136 | 137 | 138 | ;;; Node properties 139 | 140 | (defun timekeep-nodes () 141 | (let ((table (make-hash-table :test #'equal))) 142 | (dolist (node (org-roam-node-list)) 143 | (when (seq-find (-lambda ((key . _value)) 144 | (string-prefix-p "TIMEKEEP" key)) 145 | (org-roam-node-properties node)) 146 | (puthash (org-roam-node-id node) node table))) 147 | (hash-table-values table))) 148 | 149 | (defun timekeep--node-property (key node) 150 | (cl-assert (stringp key)) 151 | (cl-assert node) 152 | (alist-get key (org-roam-node-properties node) nil nil #'equal)) 153 | 154 | (defun timekeep-node-code (node &optional assert) 155 | "The code associated with NODE, e.g. for use with invoices. 156 | 157 | The value is taken from the TIMEKEEP_CODE property. 158 | 159 | If ASSERT is non-nil, throw an error on a nil result." 160 | (cl-assert node) 161 | (let ((result (timekeep--node-property "TIMEKEEP_CODE" node))) 162 | (when assert 163 | (cl-assert result)) 164 | result)) 165 | 166 | (defun timekeep-node-tag (node &optional assert) 167 | "A tag associated with NODE. 168 | 169 | The value is taken from the TIMEKEEP_TAG property, or the 170 | CATEGORY as a fallback. 171 | 172 | If ASSERT is non-nil, throw an error on a nil result." 173 | (cl-assert node) 174 | (let ((result (or (timekeep--node-property "TIMEKEEP_TAG" node) 175 | (-some->> (timekeep--node-property "CATEGORY" node) (downcase))))) 176 | (when assert 177 | (cl-assert result)) 178 | result)) 179 | 180 | (defun timekeep-node-name (node) 181 | "The human-readable name of NODE, e.g. a company or client name. 182 | 183 | The value is taken from the TIMEKEEP_NAME property. If that 184 | property is not set, it is computed using 185 | `timekeep-node-to-name-function'." 186 | (cl-assert node) 187 | (or (timekeep--node-property "TIMEKEEP_NAME" node) 188 | (funcall timekeep-node-to-name-function node))) 189 | 190 | 191 | ;;; UI prompts 192 | 193 | (persist-defvar timekeep--latest-target-id nil 194 | "The node id of the most recently clocked client or company.") 195 | 196 | (defun timekeep-current-target () 197 | (org-roam-node-from-id timekeep--latest-target-id)) 198 | 199 | (defun timekeep-read-target () 200 | (let* ((alist (seq-map (lambda (it) (cons (timekeep-node-name it) it)) 201 | (timekeep-nodes))) 202 | (choice (completing-read "Target: " alist nil t))) 203 | (alist-get choice alist nil nil #'equal))) 204 | 205 | ;;;###autoload 206 | (defun timekeep-choose-target (&optional interactive-p) 207 | "Choose a target node for clocking with timekeep. 208 | 209 | With optional argument INTERACTIVE-P, log additional messages as 210 | feedback." 211 | (interactive (list t)) 212 | (let ((node (timekeep-read-target))) 213 | (setq timekeep--latest-target-id (org-roam-node-id node)) 214 | (persist-save 'timekeep--latest-target-id) 215 | (when interactive-p 216 | (message (concat "Timekeep traget set to " (propertize (timekeep-node-name node) 217 | 'face 218 | 'font-lock-string-face)))) 219 | node)) 220 | 221 | 222 | ;;; Clocktree management & clocking integration 223 | 224 | (defun timekeep--clocktree-headline-find-or-create () 225 | (let ((heading (list timekeep-default-headline-name (format-time-string "%Y %W")))) 226 | (widen) 227 | (goto-char (marker-position (org-roam-capture-find-or-create-olp heading))))) 228 | 229 | (defun timekeep--punch-in-for-node (node) 230 | (cl-assert node) 231 | (save-window-excursion 232 | (save-excursion 233 | (org-roam-node-visit node) 234 | (org-with-wide-buffer 235 | (timekeep--clocktree-headline-find-or-create) 236 | (org-clock-in '(16)))))) 237 | 238 | (defvar timekeep--session-active-p nil) 239 | 240 | (defun timekeep--clock-in-on-default (&optional prompt-for-target-p) 241 | (timekeep--punch-in-for-node 242 | (if prompt-for-target-p 243 | (timekeep-choose-target) 244 | (or (timekeep-current-target) 245 | (timekeep-choose-target))))) 246 | 247 | (defun timekeep--ancestor-todo-pos () 248 | (let (ancestor-todo) 249 | (org-with-wide-buffer 250 | (while (and (not ancestor-todo) (org-up-heading-safe)) 251 | (when (member (nth 2 (org-heading-components)) org-todo-keywords-1) 252 | (setq ancestor-todo (point))))) 253 | ancestor-todo)) 254 | 255 | (defun timekeep--clock-in-on-parent () 256 | (org-with-wide-buffer 257 | (if-let* ((ancestor-todo (timekeep--ancestor-todo-pos))) 258 | (org-with-point-at ancestor-todo (org-clock-in)) 259 | (timekeep--clock-in-on-default)))) 260 | 261 | (defun timekeep--on-clock-in () 262 | (let* ((node (org-roam-node-at-point)) 263 | (node-id (org-roam-node-id node))) 264 | (when (seq-contains-p (seq-map #'org-roam-node-id (timekeep-nodes)) node-id) 265 | (setq timekeep--latest-target-id node-id) 266 | (persist-save 'timekeep--latest-target-id) 267 | (setq timekeep--session-active-p t)))) 268 | 269 | (defun timekeep--on-clock-out () 270 | (when (and timekeep--session-active-p 271 | (not org-clock-clocking-in) 272 | (marker-buffer org-clock-default-task) 273 | (not org-clock-resolving-clocks-due-to-idleness)) 274 | (timekeep--clock-in-on-parent))) 275 | 276 | (defun timekeep--heading-function () 277 | (let ((headline (substring-no-properties (org-get-heading t t t t)))) 278 | (format "%s/%s" 279 | (timekeep-node-name (timekeep-current-target)) 280 | (org-link-display-format headline)))) 281 | 282 | 283 | ;;;###autoload 284 | (define-minor-mode timekeep-mode 285 | "Minor mode enabling special handling of org clocks for work timekeeping. 286 | 287 | When this mode is active, clocking out behaves differently: 288 | 289 | - If clocking out of a nested todo, assume this is a task 290 | contributing to a larger unit of work. Search up for a parent 291 | todo to clock in to. 292 | 293 | - If there is no parent, clock in to a default task so that time 294 | is still tracked." 295 | :group 'timekeep 296 | :global t 297 | (if timekeep-mode 298 | (progn 299 | (setq org-clock-heading-function #'timekeep--heading-function) 300 | (add-hook 'org-clock-in-hook #'timekeep--on-clock-in) 301 | (add-hook 'org-clock-out-hook #'timekeep--on-clock-out)) 302 | (setq timekeep--session-active-p nil) 303 | (setq org-clock-heading-function nil) 304 | (remove-hook 'org-clock-in-hook #'timekeep--on-clock-in) 305 | (remove-hook 'org-clock-out-hook #'timekeep--on-clock-out))) 306 | 307 | ;;;###autoload 308 | (defun timekeep-work-tag () 309 | "Return the org tag associated with the current timekeep target. 310 | 311 | If the target does not have one the value of 312 | `timekeep-fallback-work-tag' is used." 313 | (or (-some->> (timekeep-current-target) (timekeep-node-tag)) 314 | timekeep-fallback-work-tag)) 315 | 316 | ;;;###autoload 317 | (defun timekeep-start (&optional arg) 318 | "Start a timekeeping session. 319 | 320 | The previous clock is resumed by default. 321 | 322 | With single prefix ARG, or if there is no previous clock, clock 323 | in on the default headline for the current client. 324 | 325 | With two prefix args, select from a list of recently clocked 326 | tasks. 327 | 328 | With three prefix args, prompt for the client to use and clock in 329 | on the default headline for that client." 330 | (interactive "P") 331 | (cond 332 | ((equal arg '(64)) 333 | (timekeep--clock-in-on-default t)) 334 | ((or (equal arg '(16)) 335 | (null org-clock-history) 336 | (ignore-errors 337 | ;; Would attempt to clock into the parent of the default heading? 338 | (org-with-point-at (car org-clock-history) 339 | (equal timekeep-default-headline-name (org-get-heading t t t t))))) 340 | (timekeep--clock-in-on-default)) 341 | (t 342 | (condition-case _ 343 | (org-clock-in-last (when (equal arg '(16)) 344 | '(4))) 345 | (error (timekeep--clock-in-on-default))))) 346 | 347 | (run-hooks 'timekeep-punched-in-hook) 348 | 349 | (when (derived-mode-p 'org-agenda-mode) 350 | ;; Swap agenda due to context change. 351 | (run-hooks 'timekeep-agenda-should-update-hook))) 352 | 353 | ;;;###autoload 354 | (defun timekeep-stop () 355 | "Clock out, pausing the timekeeping session." 356 | (interactive) 357 | (setq timekeep--session-active-p nil) 358 | (when (org-clocking-p) 359 | (org-clock-out)) 360 | (org-agenda-remove-restriction-lock) 361 | (org-save-all-org-buffers) 362 | 363 | (run-hooks 'timekeep-punched-out-hook) 364 | 365 | (when (derived-mode-p 'org-agenda-mode) 366 | ;; Swap agenda due to context change. 367 | (run-hooks 'timekeep-agenda-should-update-hook)) 368 | (message "Punched out.")) 369 | 370 | ;;;###autoload 371 | (defun timekeep-visit-node (&optional ask) 372 | "Open the current timekeep target node. 373 | 374 | By default, go to the current target node. With a prefix arg ASK 375 | or if no current target is set, prompt for the node to visit." 376 | (interactive "P") 377 | (org-roam-node-visit 378 | (if (or ask (null timekeep--latest-target-id)) 379 | (timekeep-choose-target t) 380 | (org-roam-node-from-id timekeep--latest-target-id)))) 381 | 382 | ;;;###autoload 383 | (defun timekeep-capture-to-clocktree () 384 | "Target-location function for use in capture templates." 385 | (timekeep-visit-node) 386 | (widen) 387 | (timekeep--clocktree-headline-find-or-create)) 388 | 389 | ;;;###autoload 390 | (defun timekeep-capture-to-toplevel () 391 | "Target-location function for use in capture templates." 392 | (timekeep-visit-node) 393 | (widen) 394 | (goto-char (point-max))) 395 | 396 | (provide 'timekeep) 397 | 398 | ;;; timekeep.el ends here 399 | -------------------------------------------------------------------------------- /lisp/org-roam-dblocks.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-dblocks.el --- Defines dynamic block types for org-roam -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; Homepage: https://github.com/chrisbarrett/nursery 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; Defines dynamic block types for use with org-roam. 25 | ;; 26 | ;; Example configuration: 27 | ;; 28 | ;; (use-package org-roam-dblocks 29 | ;; :hook (org-mode . org-roam-dblocks-autoupdate-mode)) 30 | 31 | ;; The dblock types defined are: 32 | ;; 33 | ;; - "backlinks": lists the backlinks for this node, with optional filter 34 | ;; criteria. 35 | ;; 36 | ;; E.g., in my TV Tropes note I have: 37 | ;; 38 | ;; #+BEGIN: backlinks :match trope$ 39 | ;; - [[id:...][Advanced Ancient Humans Trope]] 40 | ;; - [[id:...][Bizarre Alien Biology Trope]] 41 | ;; - [[id:...][Evil Brit Trope]] 42 | ;; - [[id:...][Humans Are Bastards Trope]] 43 | ;; - [[id:...][Lost Superweapon Trope]] 44 | ;; - [[id:...][Mega-Corporations Trope]] 45 | ;; - [[id:...][One-Man-Army Trope]] 46 | ;; - [[id:...][Precursor Alien Civilisation Trope]] 47 | ;; - [[id:...][Scary Dogmatic Aliens Trope]] 48 | ;; - [[id:...][Sealed Evil in a Can Trope]] 49 | ;; #+END: 50 | ;; 51 | ;; - "notes": lists org-roam notes based on filter criteria. 52 | ;; 53 | ;; E.g. A block that collects open questions in my Zettelkasten: 54 | ;; 55 | ;; #+BEGIN: notes :match (rx "?" eos) :tags (-answered -snooze -outline) 56 | ;; - [[id:...][Are Alien and Blade Runner in the same universe?]] 57 | ;; - [[id:...][Can attention span be increased through training?]] 58 | ;; - [[id:...][Is there research supporting the claimed benefits of the Pomodoro Technique?]] 59 | ;; #+END: 60 | 61 | ;; Options: 62 | ;; 63 | ;; - :only-missing, when non-nil, excludes links already in the node from the 64 | ;; block. 65 | ;; 66 | ;; As a use-case, you might use this to search for nodes that haven't been 67 | ;; worked into the text of the current node. 68 | ;; 69 | ;; - :include-same-file, when non-nil, includes backlinks from nodes within the 70 | ;; same file. 71 | 72 | ;; Implemented filters: 73 | ;; 74 | ;; - :match, which matches note titles (case-insensitively). 75 | 76 | ;; A match filter must be an `rx' form or regexp string. String 77 | ;; double-quotes may be safely omitted for regexps that are just a single 78 | ;; alphanumeric word. 79 | ;; 80 | ;; Examples: 81 | ;; - foo, "foo", (rx "foo") 82 | ;; - "foo bar", (rx "foo bar") 83 | ;; - "[?]$", (rx "?" eol) 84 | ;; 85 | ;; If the match contains a capture group, the text in that group is used for 86 | ;; the link description. E.g., to extract the text after "Prefix - ", you'd 87 | ;; write one of: 88 | 89 | ;; - :match "^Prefix - \\(.+\\)" 90 | ;; - :match (rx bol "Prefix - " (group (+ nonl))) 91 | ;; 92 | ;; - :tags, which matches the note's headline and file tags. 93 | ;; 94 | ;; A tags filter must be a single tag (double-quotes optional) or a list of 95 | ;; tags. Each tag may be preceded by a minus sign to indicate a forbidden tag, 96 | ;; or a plus symbol to indicate a required tag. Tags are interpreted to be 97 | ;; required if neither +/- is specified. 98 | ;; 99 | ;; Examples of tags matches: 100 | ;; - required: foo, "foo", +foo, "+foo" 101 | ;; - forbidden: -foo, "-foo" 102 | ;; - multiple tags (and-ed together): (foo "+bar" -baz) 103 | ;; 104 | ;; - :filter, and its logical opposite :remove, provide a generic way to decide 105 | ;; which nodes to include. 106 | ;; 107 | ;; A filter can be a symbol, which is interpreted to be a function name, a 108 | ;; lambda expression, or a bare S-expression. 109 | ;; 110 | ;; When a function or lambda expression is provided, it will be called on 111 | ;; each node to decide whether to include that node in results. The given 112 | ;; function should accept a single argument, which is an `org-roam-node'. 113 | ;; 114 | ;; Otherwise, the form is interpreted to be an 'anaphoric' S-expression, 115 | ;; where the symbol `it' is bound to an `org-roam-node', before being 116 | ;; evaluated. 117 | ;; 118 | ;; Examples: 119 | ;; - my-predicate 120 | ;; - (lambda (node) (zerop (org-roam-node-level node))) 121 | ;; - (zerop (org-roam-node-level it)) 122 | ;; 123 | ;; For convenience, the slots on an org-roam node are bound within an 124 | ;; anaphoric predicate. This allows you to rewrite: 125 | ;; 126 | ;; (zerop (org-roam-node-level it)) 127 | ;; 128 | ;; As the more convenient: 129 | ;; 130 | ;; (zerop level) 131 | ;; 132 | ;; If :filter and :remove are both provided, they are logically and-ed. 133 | ;; 134 | ;; - :forbidden-ids, a list of node IDs (strings) that should always be excluded 135 | ;; from results. 136 | 137 | ;; Keeping blocks up-to-date: 138 | ;; 139 | ;; These dynamic blocks can optionally be updated when opening and saving 140 | ;; buffers. To do this, enable `org-roam-dblocks-autoupdate-mode'. 141 | ;; 142 | ;; The autoupdate can be customised using `org-roam-dblocks-auto-refresh-tags' 143 | ;; so that it only runs in files/headings with specific tags. This is useful if 144 | ;; you want to have both index-style cards and stable canned searches. 145 | ;; 146 | 147 | ;;; Code: 148 | 149 | (require 'dash) 150 | (require 'org-tags-filter) 151 | (require 'plisty) 152 | (require 's) 153 | 154 | (cl-eval-when (compile) 155 | (require 'org) 156 | (require 'org-roam)) 157 | 158 | (defgroup org-roam-dblocks nil 159 | "Adds support for a dynamic block of org-roam backlinks to `org-mode'." 160 | :group 'productivity 161 | :prefix "org-roam-dblocks-") 162 | 163 | (defcustom org-roam-dblocks-auto-refresh-tags nil 164 | "A list of tags (as strings) or nil. 165 | 166 | If non-nil, only org-roam nodes with the specified tags have 167 | their blocks updated automatically." 168 | :group 'org-roam-dblocks 169 | :type '(choice (const nil) 170 | (repeat :tag "Tag" (string)))) 171 | 172 | (defcustom org-roam-dblocks-autoupdate-silently-p t 173 | "Whether to suppress messages during the dblock update process." 174 | :group 'org-roam-dblocks 175 | :type 'boolean) 176 | 177 | (defconst org-roam-dblocks-names '("notes" "backlinks")) 178 | 179 | 180 | 181 | (plisty-define org-roam-dblocks-link 182 | :required (:id :desc)) 183 | 184 | (defun org-roam-dblocks--make-list-item-formatter (params) 185 | (let* ((indent (org-roam-dblocks-args-indent params)) 186 | (prefix (concat (make-string indent ?\ ) "- "))) 187 | (lambda (link) 188 | (concat prefix 189 | (org-link-make-string (concat "id:" (org-roam-dblocks-link-id link)) 190 | (org-roam-dblocks-link-desc link)))))) 191 | 192 | (defalias 'org-roam-dblocks--link-sorting 193 | (-on #'string-lessp (-compose #'downcase #'org-roam-dblocks-link-desc))) 194 | 195 | (plisty-define org-roam-dblocks-args 196 | :optional (:id :match :tags :only-missing :include-same-file 197 | :name :indentation-column :content :forbidden-ids 198 | :filter :remove :indent)) 199 | 200 | (defun org-roam-dblocks--make-link-formatter (params) 201 | (let ((regexp-parser (when-let* ((matcher (org-roam-dblocks-args-match params))) 202 | (org-roam-dblocks--parse-regexp-form matcher)))) 203 | (lambda (node) 204 | (let ((title (org-roam-node-title node))) 205 | (org-roam-dblocks-link-create :id (org-roam-node-id node) 206 | :desc (or (when regexp-parser 207 | (cadr (s-match regexp-parser title))) 208 | title)))))) 209 | 210 | (defun org-roam-dblocks--parse-regexp-form (form) 211 | ;;; Quick tests: 212 | ;; (org-roam-dblocks--parse-regexp-form nil) 213 | ;; (org-roam-dblocks--parse-regexp-form 'hi) 214 | ;; (org-roam-dblocks--parse-regexp-form "hi") 215 | ;; (org-roam-dblocks--parse-regexp-form '(rx bol "hi" eol)) 216 | (cond 217 | ((null form) nil) 218 | ((stringp form) 219 | (unless (zerop (length form)) 220 | form)) 221 | ((symbolp form) 222 | (symbol-name form)) 223 | (t 224 | (pcase form 225 | (`(rx . ,args) 226 | (rx-to-string (cons 'and args) 227 | t)))))) 228 | 229 | (defconst org-roam-dblocks--node-slot-symbols 230 | '(file file-title file-hash file-atime file-mtime 231 | id level point todo priority scheduled deadline title properties olp 232 | tags aliases refs) 233 | "A list of slots names on org-roam-nodes. 234 | 235 | This list is used to create lexical bindings in anaphoric 236 | predicates.") 237 | 238 | (defun org-roam-dblocks--bindings-for-lexical-scope (node) 239 | (cons `(it . ,node) 240 | (seq-map (lambda (sym) 241 | (let ((slot-accessor (intern (format "org-roam-node-%s" sym)))) 242 | (cons sym (funcall slot-accessor node)))) 243 | org-roam-dblocks--node-slot-symbols))) 244 | 245 | (defun org-roam-dblocks--parse-filter-fn (keyword form) 246 | ;; Quick tests: 247 | ;; (org-roam-dblocks--parse-filter-fn :foo nil) 248 | ;; (org-roam-dblocks--parse-filter-fn :foo t) 249 | ;; (org-roam-dblocks--parse-filter-fn :foo 'ignore) 250 | ;; (org-roam-dblocks--parse-filter-fn :foo (lambda (node) node)) 251 | ;; (org-roam-dblocks--parse-filter-fn :foo '(lambda (node) node)) 252 | ;; (org-roam-dblocks--parse-filter-fn :foo 'it) 253 | ;; (org-roam-dblocks--parse-filter-fn :foo '(equal it 0)) 254 | (cl-macrolet ((lambda-with-error-handling (binding &rest body) 255 | `(lambda ,binding 256 | (condition-case-unless-debug err 257 | (progn ,@body) 258 | (error 259 | (error "Error evaluating %s form: %s" 260 | keyword 261 | (error-message-string err))))))) 262 | (cond 263 | ((null form) 264 | nil) 265 | ((functionp form) 266 | (lambda-with-error-handling (node) 267 | (funcall form node))) 268 | (t 269 | (lambda-with-error-handling (node) 270 | (eval form (org-roam-dblocks--bindings-for-lexical-scope node))))))) 271 | 272 | (defun org-roam-dblocks--compile-filter-fns (params) 273 | ;; Quick tests: 274 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter (equal "foo" it))) "foo") 275 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter (equal "foo" it))) "bar") 276 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:remove (equal "foo" it))) "foo") 277 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:remove (equal "foo" it))) "bar") 278 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter stringp :remove stringp)) "foo") 279 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter stringp :remove integerp)) "foo") 280 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter stringp :remove integerp)) 0) 281 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter integerp :remove stringp)) "foo") 282 | ;; (funcall (org-roam-dblocks--compile-filter-fns '(:filter integerp :remove stringp)) 1) 283 | (pcase-exhaustive 284 | (cons (org-roam-dblocks--parse-filter-fn :filter (org-roam-dblocks-args-filter params)) 285 | (org-roam-dblocks--parse-filter-fn :remove (org-roam-dblocks-args-remove params))) 286 | 287 | (`(nil . nil) (-const t)) 288 | (`(,filter . nil) filter) 289 | (`(nil . ,remove) (-not remove)) 290 | (`(,filter . ,remove) (-andfn filter (-not remove))))) 291 | 292 | (defun org-roam-dblocks--eval-regexp-predicate (node match) 293 | (or (null match) 294 | (string-match-p match (org-roam-node-title node)))) 295 | 296 | (defun org-roam-dblocks--eval-tags-predicate (node tags-filter) 297 | (let* ((tags (org-roam-node-tags node)) 298 | (forbidden-tags (org-tags-filter-forbidden tags-filter)) 299 | (required-tags (org-tags-filter-required tags-filter))) 300 | (not (or (seq-intersection tags forbidden-tags) 301 | (seq-difference required-tags tags))))) 302 | 303 | (defun org-roam-dblocks--compiled-predicates (params) 304 | (let ((tags (org-tags-filter-parse (org-roam-dblocks-args-tags params))) 305 | (match (org-roam-dblocks--parse-regexp-form (org-roam-dblocks-args-match params))) 306 | (predicate (org-roam-dblocks--compile-filter-fns params)) 307 | (file-for-id (org-roam-node-file (org-roam-node-from-id (org-roam-dblocks-args-id params))))) 308 | (lambda (node) 309 | (when (and (not (seq-contains-p (org-roam-dblocks-args-forbidden-ids params) 310 | (org-roam-node-id node))) 311 | (or (org-roam-dblocks-args-include-same-file params) 312 | (not (equal file-for-id (org-roam-node-file node)))) 313 | (org-roam-dblocks--eval-regexp-predicate node match) 314 | (org-roam-dblocks--eval-tags-predicate node tags) 315 | (funcall predicate node)) 316 | node)))) 317 | 318 | (defun org-roam-dblocks--links-not-in-dblocks (node) 319 | (let ((forward-links (org-roam-db-query [:select :distinct [pos dest] 320 | :from links 321 | :where (and (= type "id") (= source $s1))] 322 | (org-roam-node-id node))) 323 | (not-in-block (make-hash-table :test 'equal))) 324 | (with-temp-buffer 325 | (insert-file-contents (org-roam-node-file node)) 326 | (let ((org-inhibit-startup t) 327 | (org-inhibit-logging t)) 328 | (delay-mode-hooks (org-mode))) 329 | 330 | (pcase-dolist (`(,pos ,id) forward-links) 331 | (goto-char pos) 332 | (let ((block-args (cadr (org-element-lineage (org-element-at-point) '(dynamic-block))))) 333 | (unless (or block-args 334 | (seq-contains-p org-roam-dblocks-names (plist-get block-args :block-name))) 335 | (puthash id t not-in-block))))) 336 | (hash-table-keys not-in-block))) 337 | 338 | (defun org-roam-dblocks--compute-forbidden-ids (params) 339 | (append (list (org-roam-dblocks-args-id params)) 340 | (org-roam-dblocks-args-forbidden-ids params) 341 | (when (org-roam-dblocks-args-only-missing params) 342 | (when-let* ((node (org-roam-node-from-id (org-roam-dblocks-args-id params)))) 343 | (org-roam-dblocks--links-not-in-dblocks node))))) 344 | 345 | 346 | ;; HACK: To avoid dirtying the buffer when blocks haven't changed, we actually 347 | ;; compute the data to insert earlier, at the phase where org would normally 348 | ;; blindly clear out the block's content. We then check whether the block 349 | ;; content needs to be updated. 350 | 351 | (define-advice org-prepare-dblock (:around (fn &rest args) org-roam-dblocks-dirty-checks) 352 | "Advice to hack org's dblock update flow for the dblock types we define. 353 | 354 | FN is the advised function, and ARGS are its arguments. 355 | 356 | Populates `org-roam-dblocks--content' and ensures the buffer 357 | stays unchanged if there's no difference between the new content 358 | and old content." 359 | (unless (looking-at org-dblock-start-re) 360 | (user-error "Not at a dynamic block")) 361 | (let ((name (match-string-no-properties 1))) 362 | (if (not (member name org-roam-dblocks-names)) 363 | ;; Defer to default implementation for any dblocks we don't define in 364 | ;; this file.. 365 | (apply fn args) 366 | (let* ((indent (save-excursion 367 | (goto-char (match-beginning 0)) 368 | (back-to-indentation) 369 | (current-column))) 370 | (node-id (ignore-errors 371 | (save-match-data 372 | (org-roam-node-id (org-roam-node-at-point))))) 373 | (params (append (list :name name) 374 | (read (concat "(" (match-string 3) ")")) 375 | (list :id node-id :indent indent))) 376 | (content-start (match-end 0)) 377 | (content-end (if (re-search-forward org-dblock-end-re nil t) 378 | (1- (match-beginning 0)) 379 | (error "Dynamic block not terminated"))) 380 | (current-content (buffer-substring-no-properties content-start content-end)) 381 | (updated-content 382 | (condition-case-unless-debug err 383 | (pcase-exhaustive name 384 | ("notes" (org-roam-dblocks-format-notes params)) 385 | ("backlinks" (org-roam-dblocks-format-backlinks params))) 386 | (error 387 | (error-message-string err)))) 388 | 389 | (content-changed-p (not (equal current-content 390 | updated-content))) 391 | (params (append params (list :new-content (when content-changed-p updated-content))))) 392 | 393 | ;; Only clear the block if the content should change. 394 | (when content-changed-p 395 | (delete-region content-start content-end) 396 | (goto-char content-start)) 397 | 398 | params)))) 399 | 400 | ;;;###autoload 401 | (defun org-roam-dblocks--write-content (params) 402 | (when-let* ((new-content (plist-get params :new-content))) 403 | (insert "\n") 404 | (insert new-content))) 405 | 406 | 407 | ;;; Backlinks dblock type 408 | 409 | (defun org-roam-dblocks-format-backlinks (params) 410 | (org-roam-dblocks-args-assert params t) 411 | 412 | (setf (plist-get params :forbidden-ids) 413 | (org-roam-dblocks--compute-forbidden-ids params)) 414 | 415 | (if-let* ((id (org-roam-dblocks-args-id params)) 416 | (node (if id (org-roam-node-from-id id) (org-roam-node-at-point t))) 417 | (lines (->> (org-roam-backlinks-get node :unique t) 418 | (-keep (-compose (org-roam-dblocks--compiled-predicates params) #'org-roam-backlink-source-node)) 419 | (seq-map (org-roam-dblocks--make-link-formatter params)) 420 | (seq-sort 'org-roam-dblocks--link-sorting) 421 | (seq-map (org-roam-dblocks--make-list-item-formatter params))))) 422 | (string-join lines "\n") 423 | "")) 424 | 425 | ;;;###autoload 426 | (defalias 'org-dblock-write:backlinks #'org-roam-dblocks--write-content) 427 | 428 | ;;;###autoload 429 | (defun org-insert-dblock:backlinks () 430 | "Insert a dynamic block backlinks at point." 431 | (interactive) 432 | (atomic-change-group 433 | (org-create-dblock (list :name "backlinks"))) 434 | (org-update-dblock)) 435 | 436 | (org-dynamic-block-define "backlinks" #'org-insert-dblock:backlinks) 437 | 438 | 439 | ;;; Roam notes search dblock type 440 | 441 | (defun org-roam-dblocks-format-notes (params) 442 | (org-roam-dblocks-args-assert params t) 443 | (cl-assert (or (org-roam-dblocks-args-match params) 444 | (org-roam-dblocks-args-tags params) 445 | (org-roam-dblocks-args-filter params) 446 | (org-roam-dblocks-args-remove params)) 447 | t "Must provide at least one of :tags, :match, :filter or :remove") 448 | 449 | (setf (plist-get params :forbidden-ids) 450 | (org-roam-dblocks--compute-forbidden-ids params)) 451 | 452 | (let ((lines (->> (org-roam-node-list) 453 | (-keep (org-roam-dblocks--compiled-predicates params)) 454 | (seq-map (org-roam-dblocks--make-link-formatter params)) 455 | (seq-sort #'org-roam-dblocks--link-sorting) 456 | (seq-map (org-roam-dblocks--make-list-item-formatter params))))) 457 | (string-join lines "\n"))) 458 | 459 | ;;;###autoload 460 | (defalias 'org-dblock-write:notes #'org-roam-dblocks--write-content) 461 | 462 | (defun org-roam-dblocks--read-tags-filter-for-dblock-args () 463 | (let* ((tags-filter (org-tags-filter-read)) 464 | (unpacked (append (seq-map (lambda (it) (concat "-" it)) (org-tags-filter-forbidden tags-filter)) 465 | (org-tags-filter-required tags-filter)))) 466 | (if (equal 1 (length unpacked)) 467 | (car unpacked) 468 | unpacked))) 469 | 470 | ;;;###autoload 471 | (defun org-insert-dblock:notes () 472 | "Insert a dynamic block org-roam notes at point." 473 | (interactive) 474 | (let ((args (pcase-exhaustive (completing-read "Query Type: " '("Title Regexp Match" "Tags Filter")) 475 | ("Title Regexp Match" 476 | (list :match (read-string "Match title (regexp): "))) 477 | ("Tags Filter" 478 | (list :tags (org-roam-dblocks--read-tags-filter-for-dblock-args)))))) 479 | (atomic-change-group 480 | (org-create-dblock (append '(:name "notes") args)))) 481 | (org-update-dblock)) 482 | 483 | 484 | (org-dynamic-block-define "notes" #'org-insert-dblock:notes) 485 | 486 | 487 | 488 | (defun org-roam-dblocks--update-block-at-point-p () 489 | (when (derived-mode-p 'org-mode) 490 | (or (null org-roam-dblocks-auto-refresh-tags) 491 | (seq-intersection org-roam-dblocks-auto-refresh-tags 492 | (append org-file-tags (org-get-tags)))))) 493 | 494 | (defun org-roam-dblocks--update-blocks () 495 | (let ((message-log-max (if org-roam-dblocks-autoupdate-silently-p nil message-log-max))) 496 | (org-map-dblocks 497 | (lambda () 498 | (when (org-roam-dblocks--update-block-at-point-p) 499 | (pcase (org-element-at-point) 500 | (`(dynamic-block ,plist) 501 | (when (member (plist-get plist :block-name) org-roam-dblocks-names) 502 | (org-update-dblock))))))))) 503 | 504 | 505 | 506 | ;;;###autoload 507 | (define-minor-mode org-roam-dblocks-autoupdate-mode 508 | "Automatically update org-roam-dblocks blocks on open and save." 509 | :init-value nil 510 | (cond 511 | (org-roam-dblocks-autoupdate-mode 512 | (org-roam-dblocks--update-blocks) 513 | (when (and (buffer-file-name) (buffer-modified-p)) 514 | (let ((message-log-max (if org-roam-dblocks-autoupdate-silently-p nil message-log-max))) 515 | (save-buffer))) 516 | (add-hook 'before-save-hook #'org-roam-dblocks--update-blocks nil t)) 517 | (t 518 | (remove-hook 'before-save-hook #'org-roam-dblocks--update-blocks)))) 519 | 520 | (provide 'org-roam-dblocks) 521 | 522 | ;;; org-roam-dblocks.el ends here 523 | -------------------------------------------------------------------------------- /lisp/org-roam-rewrite.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-rewrite.el --- Commands for rewriting org-roam nodes and their links -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Homepage: https://github.com/chrisbarrett/nursery 6 | 7 | ;; Author: Chris Barrett 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; Provides commands for rewriting links and removing nodes in a structured way, 25 | ;; to reduce the likelihood of leaving broken links in your org-roam files. 26 | 27 | ;;; Code: 28 | 29 | (require 'dash) 30 | (require 'org) 31 | (require 'org-roam) 32 | (require 'plisty) 33 | 34 | (require 'org-transclusion nil t) 35 | 36 | (defgroup org-roam-rewrite nil 37 | "Commands for rewriting org-roam nodes and their links." 38 | :group 'productivity 39 | :prefix "org-roam-rewrite-") 40 | 41 | (defcustom org-roam-rewrite-extract-excluded-tags '("ATTACH") 42 | "Tags that should not be propagated when extracting nodes." 43 | :group 'org-roam-rewrite 44 | :type '(repeat string)) 45 | 46 | (defcustom org-roam-rewrite-confirm-extraction-path-p nil 47 | "Whether to confirm the path to extract to with `org-roam-rewrite-extract'." 48 | :group 'org-roam-rewrite 49 | :type 'boolean) 50 | 51 | (defcustom org-roam-rewrite-insert-link-after-extraction-p t 52 | "Whether to insert a link to nodes extracted with `org-roam-rewrite-extract'." 53 | :group 'org-roam-rewrite 54 | :type 'boolean) 55 | 56 | (defcustom org-roam-rewrite-rename-without-confirmation-p nil 57 | "Whether to ask for confirmation before updating links to renamed nodes." 58 | :group 'org-roam-rewrite 59 | :type 'boolean) 60 | 61 | (defcustom org-roam-rewrite-backlink-transformer #'org-roam-rewrite-backlink-transformer 62 | "Function to transform link data used to populate links in rewrites. 63 | 64 | It should take a single argument, a plist conforming to 65 | `org-roam-rewrite-backlink-transformer-args', and return a plist 66 | conforming to `org-roam-rewrite-backlink-transformer-result'." 67 | :group 'org-roam-rewrite 68 | :type 'function) 69 | 70 | (defcustom org-roam-rewrite-backlink-modified-functions nil 71 | "Hook function run after a backlink is modified. 72 | 73 | It is called with the renamed link at point, and is passed two arguments: 74 | 75 | 1. a plist containing information about the link before and after 76 | the rename, but before the link transformer has possibly made 77 | modifications. It conforms to 78 | `org-roam-rewrite-backlink-transformer-args'. 79 | 80 | 2. a plist containing the data used to construct the new link. It 81 | conforms to `org-roam-rewrite-backlink-transformer-result'." 82 | :group 'org-roam-rewrite 83 | :type 'hook) 84 | 85 | (defcustom org-roam-rewrite-backlinks-modified-in-file-functions nil 86 | "Hook run after processing backlinks in a file caused modifications. 87 | 88 | It is called with a single argument: the file name that was modified." 89 | :group 'org-roam-rewrite 90 | :type 'hook) 91 | 92 | (defcustom org-roam-rewrite-node-extracted-hook nil 93 | "Hook run after a node has been extracted successfully to a new file. 94 | 95 | It is called with the new node as the current buffer." 96 | :group 'org-roam-rewrite 97 | :type 'hook) 98 | 99 | (defcustom org-roam-rewrite-node-removed-functions nil 100 | "Hook functions run after a node has been removed. 101 | 102 | It is called with a plist, containing the following attributes 103 | from the original node: :title, :level, :file, :id" 104 | :group 'org-roam-rewrite 105 | :type 'hook) 106 | 107 | (defcustom org-roam-rewrite-node-renamed-hook nil 108 | "Hook executed after renaming a node. 109 | 110 | It is called with the renamed node as the current buffer." 111 | :group 'org-roam-rewrite 112 | :type 'hook) 113 | 114 | 115 | 116 | (defun org-roam-rewrite--set-title-keyword (text) 117 | (org-with-wide-buffer 118 | (goto-char (point-min)) 119 | (save-match-data 120 | (search-forward-regexp (rx bol "#+title:" (* space) (group (+ any)) eol)) 121 | (replace-match text t nil nil 1)))) 122 | 123 | (defun org-roam-rewrite--set-file-tags (tags) 124 | (org-with-wide-buffer 125 | (goto-char (point-min)) 126 | (unless (search-forward-regexp (rx bol "#+filetags:" (group (* nonl))) nil t) 127 | (cond ((search-forward-regexp (rx bol "#+title:")) 128 | (goto-char (line-end-position)) 129 | (insert "\n#+filetags:")) 130 | (t 131 | (insert "#+filetags:\n")))) 132 | 133 | (let ((formatted (if tags 134 | (format ":%s:" (string-join tags ":")) 135 | ""))) 136 | (save-match-data 137 | (goto-char (point-min)) 138 | (when (search-forward-regexp (rx bol "#+filetags:" (group (* nonl)))) 139 | (replace-region-contents (match-beginning 1) (match-end 1) 140 | (lambda () 141 | (concat " " formatted)))))))) 142 | 143 | (defun org-roam-rewrite--file-tags () 144 | (save-match-data 145 | (org-with-wide-buffer 146 | (goto-char (point-min)) 147 | (when (search-forward-regexp (rx bol "#+filetags:" (group (+ nonl))) 148 | nil 149 | t) 150 | (split-string (string-trim (substring-no-properties (match-string 1))) ":" t))))) 151 | 152 | 153 | 154 | (plisty-define org-roam-rewrite-backlink-transformer-args 155 | :required (:prev-node :new-node 156 | :prev-id :prev-desc 157 | :new-id :new-desc)) 158 | 159 | (plisty-define org-roam-rewrite-backlink-transformer-result 160 | :required (:id :desc)) 161 | 162 | (defun org-roam-rewrite--normalise-title (title) 163 | (replace-regexp-in-string (rx (+ (any space "\n"))) "" 164 | (downcase title))) 165 | 166 | (defun org-roam-rewrite-backlink-transformer (args-plist) 167 | (-let* (((&plist :prev-node :new-id :new-desc :prev-desc) 168 | args-plist) 169 | 170 | (norm-titles (cons (org-roam-rewrite--normalise-title (org-roam-node-title prev-node)) 171 | (seq-map #'org-roam-rewrite--normalise-title (org-roam-node-aliases prev-node)))) 172 | 173 | (desc-customised-p 174 | (not (seq-contains-p norm-titles (org-roam-rewrite--normalise-title prev-desc)))) 175 | 176 | (updated-desc 177 | (if desc-customised-p prev-desc new-desc))) 178 | 179 | (list :id new-id :desc updated-desc))) 180 | 181 | (defun org-roam-rewrite--parse-link-at-point () 182 | (save-match-data 183 | (when (looking-at org-link-any-re) 184 | (-let* ((beg (match-beginning 0)) 185 | (end (match-end 0)) 186 | (str (buffer-substring-no-properties beg end)) 187 | (((_link (&plist :path id) desc)) (org-element-parse-secondary-string str '(link)))) 188 | (list :beg beg :end end :id id :desc (substring-no-properties desc)))))) 189 | 190 | (defun org-roam-rewrite--edit-backlinks (prev-node new-node new-desc) 191 | (let* ((backlinks-by-file 192 | (seq-group-by (-compose #'org-roam-node-file #'org-roam-backlink-source-node) 193 | (org-roam-backlinks-get prev-node)))) 194 | (pcase-dolist (`(,file . ,backlinks) backlinks-by-file) 195 | (with-temp-buffer 196 | (let ((modified-p)) 197 | 198 | (insert-file-contents file) 199 | (dolist (backlink (seq-sort-by #'org-roam-backlink-point #'> backlinks)) 200 | (goto-char (org-roam-backlink-point backlink)) 201 | (-when-let* (((&plist :beg :end :id prev-id :desc prev-desc) 202 | (org-roam-rewrite--parse-link-at-point)) 203 | 204 | (transformer-args 205 | (org-roam-rewrite-backlink-transformer-args-create 206 | :prev-node prev-node 207 | :new-node new-node 208 | :prev-id prev-id 209 | :prev-desc prev-desc 210 | :new-id (org-roam-node-id new-node) 211 | :new-desc new-desc)) 212 | (transformed 213 | (org-roam-rewrite-backlink-transformer-result-assert 214 | (funcall org-roam-rewrite-backlink-transformer transformer-args))) 215 | 216 | ((&plist :desc new-desc :id new-id) transformed)) 217 | 218 | (replace-region-contents beg end (lambda () 219 | (org-link-make-string (concat "id:" new-id) new-desc))) 220 | (setq modified-p t) 221 | (run-hook-with-args 'org-roam-rewrite-backlink-modified-functions transformer-args transformed))) 222 | 223 | (write-region (point-min) (point-max) file) 224 | (when modified-p 225 | (run-hook-with-args 'org-roam-rewrite-backlinks-modified-in-file-functions file))))) 226 | 227 | (pcase-dolist (`(,file . ,_) backlinks-by-file) 228 | (when-let* ((buf (find-buffer-visiting file))) 229 | (with-current-buffer buf 230 | (revert-buffer t t))))) 231 | 232 | ;; Tell org-roam that files changed behind its back. 233 | (org-roam-db-sync)) 234 | 235 | (defun org-roam-rewrite--update-node-title (node new-title) 236 | (org-id-goto (org-roam-node-id node)) 237 | (cond ((equal 0 (org-roam-node-level node)) 238 | (org-roam-rewrite--set-title-keyword new-title)) 239 | ((looking-at org-complex-heading-regexp) 240 | (replace-match new-title t t nil 4))) 241 | (save-buffer)) 242 | 243 | (defun org-roam-rewrite--delete-node-kill-buffer (node) 244 | (let ((level (org-roam-node-level node)) 245 | (file (org-roam-node-file node)) 246 | (id (org-roam-node-id node))) 247 | (cond 248 | ((zerop level) 249 | (when-let* ((buf (find-buffer-visiting file))) 250 | (kill-buffer buf)) 251 | (delete-file file)) 252 | (t 253 | (let ((buffer-visiting-p (find-buffer-visiting file))) 254 | (org-with-point-at (org-roam-node-marker node) 255 | (goto-char (point-min)) 256 | (when (search-forward-regexp (rx-to-string `(and 257 | bol 258 | (* space) ":ID:" 259 | (* space) 260 | ,id))) 261 | (let ((message-log-max)) 262 | (org-cut-subtree))) 263 | (save-buffer) 264 | (unless buffer-visiting-p 265 | (kill-buffer)))))) 266 | (run-hook-with-args 'org-roam-rewrite-node-removed-functions 267 | (list :title (org-roam-node-title node) :id id :file file :level level)))) 268 | 269 | (defun org-roam-rewrite--node-formatted-title (node &optional default) 270 | (if org-roam-node-formatter 271 | (funcall org-roam-node-formatter node) 272 | (or default 273 | (org-roam-node-title node)))) 274 | 275 | ;;;###autoload 276 | (defun org-roam-rewrite-rename (node new-title) 277 | "Change the title of a node and update links to match. 278 | 279 | NODE is the node to update. 280 | 281 | NEW-TITLE is the new title to use. All backlinks will have their 282 | descriptions updated according to the behaviour of the function 283 | bound to variable `org-roam-rewrite-backlink-transformer'." 284 | (interactive (let ((node (or (org-roam-node-at-point) (org-roam-node-read)))) 285 | (list node (read-string "New title: " (org-roam-node-title node))))) 286 | (org-roam-node-visit node) 287 | (org-save-all-org-buffers) 288 | (org-roam-rewrite--update-node-title node new-title) 289 | (let* ((node-id (org-roam-node-id node)) 290 | ;; Get an updated node with the new title. 291 | (updated-node (org-roam-node-from-id node-id)) 292 | (backlinks (org-roam-backlinks-get node))) 293 | (cond 294 | ((null backlinks) 295 | (message "Renamed. No backlinks to update.")) 296 | (t 297 | (cond ((or org-roam-rewrite-rename-without-confirmation-p 298 | (y-or-n-p (format "Modify %s backlink description%s? " 299 | (length backlinks) 300 | (if (= 1 (length backlinks)) "" "s")))) 301 | 302 | (let ((new-desc (org-roam-rewrite--node-formatted-title updated-node new-title))) 303 | (org-roam-rewrite--edit-backlinks node updated-node new-desc)) 304 | 305 | (message "Rewrote %s link%s to node." 306 | (length backlinks) 307 | (if (= 1 (length backlinks)) "" "s"))) 308 | (t 309 | (message "Rename completed."))))) 310 | (run-hooks 'org-roam-rewrite-node-renamed-hook))) 311 | 312 | ;;;###autoload 313 | (defun org-roam-rewrite-remove (from to link-desc) 314 | "Redirect links from one node to a replacement node. 315 | 316 | Optionally, delete the original node after all links are 317 | redirected. 318 | 319 | FROM is the node which will be unlinked. 320 | 321 | TO is the node to change those references to point to. 322 | 323 | LINK-DESC is the description to use for the updated links." 324 | (interactive (let* ((from (org-roam-node-at-point t)) 325 | (backlinks (progn 326 | (org-save-all-org-buffers) 327 | (org-roam-backlinks-get from)))) 328 | (if (zerop (length backlinks)) 329 | (list from nil nil) 330 | (let* ((to (org-roam-node-read nil (lambda (it) (not (equal from it))) nil t "Rewrite to: ")) 331 | (desc (read-string "Link description: " (org-roam-rewrite--node-formatted-title to)))) 332 | (list from to desc))))) 333 | (let ((backlinks (org-roam-backlinks-get from))) 334 | (cond 335 | ((null backlinks) 336 | (when (y-or-n-p "No links found. Delete node? ") 337 | (org-roam-rewrite--delete-node-kill-buffer from))) 338 | 339 | ((or (null to) (null link-desc)) 340 | (user-error "Must provide a node to redirect existing links to")) 341 | 342 | ((y-or-n-p (format "Rewriting %s link%s from \"%s\" -> \"%s\". Continue? " 343 | (length backlinks) 344 | (if (= 1 (length backlinks)) "" "s") 345 | (org-roam-node-title from) 346 | link-desc)) 347 | (org-roam-rewrite--edit-backlinks from to link-desc) 348 | (when (y-or-n-p "Rewrite completed. Delete node? ") 349 | (org-roam-rewrite--delete-node-kill-buffer from))) 350 | (t 351 | (user-error "Rewrite aborted"))))) 352 | 353 | (defmacro org-roam-rewrite--when-transclusions (&rest body) 354 | (declare (indent 0)) 355 | `(when (bound-and-true-p org-transclusion-mode) 356 | ,@body)) 357 | 358 | ;;;###autoload 359 | (defun org-roam-rewrite-inline (src-node dest-node) 360 | "Inline the contents of one org-roam node into another, removing the original. 361 | 362 | SRC-NODE is the node to be removed. 363 | 364 | DEST-NODE is the node that will be added to." 365 | (interactive 366 | (let* ((suggested-title (-some->> (org-roam-node-at-point) (org-roam-node-title))) 367 | (src (org-roam-node-read suggested-title nil nil t "Source: ")) 368 | (dest (org-roam-node-read nil (lambda (node) 369 | (and 370 | (not (equal (org-roam-node-id node) (org-roam-node-id src))) 371 | (zerop (org-roam-node-level node)) 372 | (not (seq-contains-p (org-roam-node-tags node) "dailies")))) 373 | nil t "Destination: "))) 374 | (list src dest))) 375 | 376 | (let* ((org-inhibit-startup t) 377 | (src-buffer (find-file-noselect (org-roam-node-file src-node))) 378 | (content 379 | (with-current-buffer src-buffer 380 | (org-with-wide-buffer 381 | (org-roam-rewrite--when-transclusions 382 | (org-transclusion-remove-all)) 383 | (goto-char (point-min)) 384 | (org-roam-end-of-meta-data t) 385 | (buffer-substring (point) (point-max)))))) 386 | (find-file (org-roam-node-file dest-node)) 387 | (org-with-wide-buffer 388 | (org-roam-rewrite--when-transclusions 389 | (org-transclusion-remove-all)) 390 | (goto-char (point-max)) 391 | (delete-blank-lines) 392 | (insert "\n\n") 393 | (insert (format "* %s\n" (org-roam-node-title src-node))) 394 | (org-set-property "ID" (org-roam-node-id src-node)) 395 | (save-restriction 396 | (narrow-to-region (point) (point-max)) 397 | (insert content) 398 | (org-map-entries 'org-do-demote) 399 | (goto-char (point-min)) 400 | (while (search-forward-regexp (rx bol "#+transclude:") nil t) 401 | (org-roam-rewrite--when-transclusions 402 | (org-transclusion-add)) 403 | (org-roam-rewrite--when-transclusions 404 | (org-transclusion-promote-subtree))))) 405 | (delete-file (org-roam-node-file src-node)) 406 | (save-buffer) 407 | (org-roam-rewrite--when-transclusions 408 | (org-transclusion-add-all)) 409 | (when (buffer-live-p src-buffer) 410 | (kill-buffer src-buffer))) 411 | 412 | (org-roam-node-visit dest-node) 413 | (message "Inlined node successfully")) 414 | 415 | (defun org-roam-rewrite--ensure-node-for-headline-at-point () 416 | (save-excursion 417 | (org-back-to-heading-or-point-min t) 418 | (when (bobp) (user-error "Already a top-level node")) 419 | (org-id-get-create) 420 | (save-buffer) 421 | (org-roam-db-update-file) 422 | (org-roam-node-at-point t))) 423 | 424 | (defun org-roam-rewrite--new-filename-from-capture-template (node) 425 | (unwind-protect 426 | (progn 427 | (setq org-capture-plist nil) 428 | (org-roam-format-template 429 | (string-trim (org-capture-fill-template org-roam-extract-new-file-path)) 430 | (lambda (key default-val) 431 | (let ((fn (intern key)) 432 | (node-fn (intern (concat "org-roam-node-" key)))) 433 | (cond 434 | ((fboundp fn) 435 | (funcall fn node)) 436 | ((fboundp node-fn) 437 | (funcall node-fn node)) 438 | (t 439 | (read-from-minibuffer (format "%s: " key) default-val))))))) 440 | (setq org-capture-plist nil))) 441 | 442 | ;;;###autoload 443 | (defun org-roam-rewrite-extract (node dest) 444 | "Extract NODE to a new file at DEST. 445 | 446 | Note that NODE must be a headline, not at the top-level of the 447 | file. If NODE is at the top-level an error is signalled. 448 | 449 | If called interactively, ensure the headline at point has an ID 450 | before extracting. 451 | 452 | This is a rough reimplementation of `org-roam-extract-subtree', 453 | but it handles file titles, tags and transclusions better." 454 | (interactive (let* ((node (org-roam-rewrite--ensure-node-for-headline-at-point)) 455 | (template (org-roam-rewrite--new-filename-from-capture-template node)) 456 | (relpath (file-name-as-directory org-roam-directory)) 457 | (dest (expand-file-name 458 | (if org-roam-rewrite-confirm-extraction-path-p 459 | (read-file-name "Extract node to: " relpath template nil template) 460 | template) 461 | org-roam-directory))) 462 | (list node dest))) 463 | 464 | (cl-assert (org-roam-node-level node) t) 465 | (cl-assert (not (zerop (org-roam-node-level node))) t) 466 | 467 | (with-current-buffer (find-file-noselect (org-roam-node-file node)) 468 | (org-roam-rewrite--when-transclusions 469 | (org-transclusion-remove-all)) 470 | 471 | ;; Use underlying org-mode machinery to go to the ID in the buffer. We can't 472 | ;; use org-roam-node-marker because updates aren't reliable. 473 | (org-with-point-at (org-id-find (org-roam-node-id node) t) 474 | (let ((tags (org-get-tags)) 475 | (save-silently t) 476 | (dest-buf (find-file-noselect dest)) 477 | extraction-succeeded-p) 478 | (unwind-protect 479 | (atomic-change-group 480 | ;; Extract from source buffer 481 | (org-cut-subtree) 482 | (save-buffer) 483 | (org-roam-db-update-file) 484 | (when org-roam-rewrite-insert-link-after-extraction-p 485 | (insert (org-link-make-string (format "id:%s" (org-roam-node-id node)) 486 | (org-link-display-format (org-roam-rewrite--node-formatted-title node)))) 487 | (newline)) 488 | (org-roam-rewrite--when-transclusions 489 | (org-transclusion-add-all)) 490 | 491 | ;; Insert into dest buffer 492 | (with-current-buffer dest-buf 493 | (org-paste-subtree) 494 | (while (> (org-current-level) 1) (org-promote-subtree)) 495 | 496 | ;; `org-roam-promote-entire-buffer' expects an indexed node to 497 | ;; exist, and the file must exist on-disk for indexing to succeed. 498 | (let ((before-save-hook) 499 | (after-save-hook 500 | (lambda () 501 | (org-id-add-location (org-roam-node-id node) dest)))) 502 | (save-buffer)) 503 | (org-roam-promote-entire-buffer) 504 | 505 | (let ((tags (-difference (-union (org-roam-rewrite--file-tags) tags) 506 | org-roam-rewrite-extract-excluded-tags))) 507 | (org-roam-rewrite--set-file-tags tags) 508 | (org-roam-rewrite--when-transclusions 509 | (org-transclusion-add-all))) 510 | (save-buffer)) 511 | 512 | (setq extraction-succeeded-p t)) 513 | 514 | (unless extraction-succeeded-p 515 | (message "Extraction failed") 516 | (with-current-buffer dest-buf 517 | (let ((kill-buffer-query-functions)) 518 | (set-buffer-modified-p nil) 519 | (kill-buffer dest-buf)) 520 | (when (file-exists-p dest) 521 | (delete-file dest))))) 522 | 523 | (save-buffer) 524 | (with-current-buffer dest-buf 525 | (run-hooks 'org-roam-capture-new-node-hook 'org-roam-rewrite-node-extracted-hook)))))) 526 | 527 | (provide 'org-roam-rewrite) 528 | 529 | ;;; org-roam-rewrite.el ends here 530 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /lisp/org-roam-review.el: -------------------------------------------------------------------------------- 1 | ;;; org-roam-review.el --- Extends org-roam with spaced-repetition review of nodes -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022 Chris Barrett 4 | 5 | ;; Author: Chris Barrett 6 | 7 | ;; Homepage: https://github.com/chrisbarrett/nursery 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License along with 20 | ;; this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; Provides commands to categorise and review org-roam nodes for Evergreen 25 | ;; note-taking. Notes are surfaced using the spaced-repetition algorithm from 26 | ;; org-drill. 27 | 28 | ;; The main entrypoint is `M-x org-roam-review', which shows your nodes due for 29 | ;; review and refinement. With a prefix argument, that command will list all 30 | ;; your nodes by category, which is useful for getting a quick overview of your 31 | ;; Evergreens. 32 | 33 | ;; Example configuration: 34 | ;; 35 | ;; (use-package org-roam-review 36 | ;; :commands (org-roam-review 37 | ;; org-roam-review-list-by-maturity 38 | ;; org-roam-review-list-recently-added) 39 | ;; ;; Optional - tag all newly-created notes as seedlings 40 | ;; :hook (org-roam-capture-new-node . org-roam-review-set-seedling) 41 | ;; :general 42 | ;; ;; Optional - bindings for evil-mode compatability. 43 | ;; (:states '(normal) :keymaps 'org-roam-review-mode-map 44 | ;; "TAB" 'magit-section-cycle 45 | ;; "g r" 'org-roam-review-refresh) 46 | ;; (:keymaps 'org-mode-map 47 | ;; "C-c r r" '(org-roam-review-accept :wk "accept") 48 | ;; "C-c r f" '(org-roam-review-forgot :wk "forgot") 49 | ;; "C-c r u" '(org-roam-review-bury :wk "bury") 50 | ;; "C-c r m" '(org-roam-review-set-memorise :wk "set memorise") 51 | ;; "C-c r x" '(org-roam-review-set-excluded :wk "set excluded") 52 | ;; "C-c r b" '(org-roam-review-set-budding :wk "set budding") 53 | ;; "C-c r s" '(org-roam-review-set-seedling :wk "set seedling") 54 | ;; "C-c r e" '(org-roam-review-set-evergreen :wk "set evergreen"))) 55 | 56 | ;;; Code: 57 | 58 | (require 'dash) 59 | (require 'org-drill) 60 | (require 'org-roam-dailies) 61 | (require 'org-roam-node) 62 | (require 'org-tags-filter) 63 | (require 'plisty) 64 | (require 'ts) 65 | 66 | (declare-function org-roam-slipbox-refile "org-roam-slipbox") 67 | 68 | (defgroup org-roam-review nil 69 | "Extends org-roam with spaced-repetition review of nodes." 70 | :group 'productivity 71 | :prefix "org-roam-review-") 72 | 73 | (defcustom org-roam-review-tags-ignored-for-review-buffer '("dailies") 74 | "A list of tags that disqualify a node from review." 75 | :group 'org-roam-review 76 | :type '(list string)) 77 | 78 | (defcustom org-roam-review-show-instructions-p t 79 | "Whether to show instructions in review buffers." 80 | :group 'org-roam-review 81 | :type 'boolean) 82 | 83 | (defcustom org-roam-review-ignored-tags '("dailies") 84 | "A list of tags for nodes that should never be reviewable." 85 | :group 'org-roam-review 86 | :type '(list string)) 87 | 88 | (defcustom org-roam-review-kill-reviewed-buffers-p t 89 | "Whether to kill a buffer after it has been accepted in a review." 90 | :group 'org-roam-review 91 | :type 'boolean) 92 | 93 | (defcustom org-roam-review-title-formatter #'org-roam-review-default-title-formatter 94 | "Function that renders node title in review buffers. 95 | 96 | It must take a node and return a (possibly propertized) string." 97 | :group 'org-roam-review 98 | :type 'function) 99 | 100 | (defcustom org-roam-review-memo-slipbox nil 101 | "A slipbox to save memo notes to. 102 | 103 | If set, marking a node as a memo note with 104 | `org-roam-review-set-memorise' will also refile." 105 | :group 'org-roam-review 106 | :type '(choice (string :tag "Slipbox name") 107 | (const :tag "none" nil))) 108 | 109 | (defface org-roam-review-instructions 110 | '((t 111 | (:inherit font-lock-comment-face))) 112 | "Face for instructional information in a review buffer." 113 | :group 'org-roam-review) 114 | 115 | (defface org-roam-review-heading 116 | '((t (:inherit org-level-2 :bold t))) 117 | "Face for headings in review buffers." 118 | :group 'org-roam-review) 119 | 120 | (defface org-roam-review-tags-filter-keyword 121 | '((t (:bold t))) 122 | "Face for the tags heading in review buffers." 123 | :group 'org-roam-review) 124 | 125 | (defface org-roam-review-tags-filter 126 | '((t (:italic t))) 127 | "Face for tag filter text in review buffers." 128 | :group 'org-roam-review) 129 | 130 | (defconst org-roam-review-maturity-values '("seedling" "evergreen" "budding")) 131 | 132 | (defconst org-roam-review-maturity-emoji-alist 133 | '(("seedling" . "🌱") 134 | ("budding" . "🪴") 135 | ("evergreen" . "🌲"))) 136 | 137 | (defconst org-roam-review-properties 138 | '("LAST_REVIEW" 139 | "NEXT_REVIEW" 140 | "MATURITY" 141 | "DRILL_LAST_INTERVAL" 142 | "DRILL_REPEATS_SINCE_FAIL" 143 | "DRILL_TOTAL_REPEATS" 144 | "DRILL_FAILURE_COUNT" 145 | "DRILL_AVERAGE_QUALITY" 146 | "DRILL_EASE") 147 | "List of properties managed by `org-roam-review'.") 148 | 149 | (defvar org-roam-review-node-accepted-hook nil 150 | "Hook run after marking a node as successfully reviewed. 151 | 152 | The hook is run within `org-roam-review-accept', with that node 153 | as the current buffer.") 154 | 155 | (defvar org-roam-review-node-forgotten-hook nil 156 | "Hook run after marking a node as forgotten. 157 | 158 | The hook is run within `org-roam-review-forgot', with that node 159 | as the current buffer.") 160 | 161 | (defvar org-roam-review-node-buried-hook nil 162 | "Hook run after marking a node as successfully reviewed. 163 | 164 | The hook is run within `org-roam-review-bury', with that node as 165 | the current buffer.") 166 | 167 | (defvar org-roam-review-node-processed-hook '(org-roam-review--update-workspace-for-completed-review) 168 | "Hook run whenever a node is buried or accepted in a review. 169 | 170 | The hook is run with the node as the current buffer.") 171 | 172 | (defvar org-roam-review-next-node-selected-hook '(org-roam-review-open-node-if-in-review-session) 173 | "A hook executed when point advances to the next node for review. 174 | 175 | Running `org-roam-review-accept' or `org-roam-review-bury' causes 176 | point to advance to the next section in the review buffer, when 177 | open. The hook is runs with the review buffer as the current 178 | buffer, and with point at the section corresponding to the next 179 | node for review. 180 | 181 | The default value for this hook means the next node for 182 | review is automatically opened, where available.") 183 | 184 | 185 | ;;; SRS property management & parsing 186 | 187 | ;; We parse & store a number of properties on nodes to track review state. 188 | 189 | (defvar org-roam-review--maturity-score-revisit 1) 190 | (defvar org-roam-review--maturity-score-ok 4) 191 | (defvar org-roam-review--maturity-score-bury 5) 192 | 193 | (defun org-roam-review--update-next-review (quality) 194 | "Adapted from org-drill. 195 | 196 | QUALITY is a number 0-5 inclusive. 197 | 198 | - only use sm5 algorithm for simplicity 199 | - use properties instead of SCHEDULED. 200 | - remove support for 'weighting' a node." 201 | (-let* ((ofmatrix org-drill-sm5-optimal-factor-matrix) 202 | ((last-interval repetitions failures total-repeats meanq ease) (org-drill-get-item-data)) 203 | ((next-interval repetitions ease failures meanq total-repeats new-ofmatrix) 204 | (org-drill-determine-next-interval-sm5 last-interval repetitions 205 | ease quality failures 206 | meanq total-repeats ofmatrix)) 207 | (next-interval (round (if (cl-minusp next-interval) 208 | next-interval 209 | (max 1.0 (+ last-interval (- next-interval last-interval)))))) 210 | (new-time (ts-adjust 'day next-interval (ts-now)))) 211 | (setq org-drill-sm5-optimal-factor-matrix new-ofmatrix) 212 | (org-drill-store-item-data next-interval repetitions failures total-repeats meanq ease) 213 | 214 | (let ((next-review (ts-format "[%Y-%m-%d %a]" new-time))) 215 | (org-set-property "NEXT_REVIEW" next-review) 216 | next-review))) 217 | 218 | (defun org-roam-review--update-node-srs-properties (score &optional maturity) 219 | "Set the MATURITY and updated SCORE for a node. 220 | 221 | A higher score means that the node will appear less frequently." 222 | (cl-assert (or (null maturity) (member maturity org-roam-review-maturity-values))) 223 | (cl-assert (derived-mode-p 'org-mode)) 224 | (when (and maturity (org-roam-review--daily-file-p (buffer-file-name))) 225 | (user-error "Cannot set maturity on daily file")) 226 | (let ((id (org-entry-get (point-min) "ID"))) 227 | (unless id 228 | (error "Not visiting an org-roam node--no ID property found")) 229 | (org-with-point-at (org-find-property "ID" id) 230 | (atomic-change-group 231 | (let ((next-review (org-roam-review--update-next-review score))) 232 | (ignore-errors 233 | (org-roam-tag-remove org-roam-review-maturity-values)) 234 | 235 | (when maturity 236 | (org-roam-tag-add (list maturity)) 237 | (org-set-property "MATURITY" maturity)) 238 | 239 | (org-set-property "LAST_REVIEW" (format-time-string "[%Y-%m-%d %a]")) 240 | 241 | (save-buffer) 242 | 243 | (if maturity 244 | (message "Maturity set to '%s'. Review scheduled for %s" maturity next-review) 245 | (message "Review scheduled for %s" next-review))))))) 246 | 247 | (defun org-roam-review-node-ignored-p (node &optional filter-plist) 248 | (let* ((filter-plist (or filter-plist org-tags-filter-last-value)) 249 | (tags (org-roam-node-tags node)) 250 | (forbidden-tags (org-tags-filter-forbidden filter-plist)) 251 | (required-tags (org-tags-filter-required filter-plist))) 252 | (or (seq-intersection tags forbidden-tags) 253 | (seq-difference required-tags tags)))) 254 | 255 | (defun org-roam-review-node-created-at (node) 256 | (-when-let* (((&alist "CREATED" created) (org-roam-node-properties node))) 257 | (ts-parse-org created))) 258 | 259 | (defun org-roam-review-node-next-review (node) 260 | (-when-let* (((&alist "NEXT_REVIEW" next-review) (org-roam-node-properties node))) 261 | (ts-parse-org next-review))) 262 | 263 | (defun org-roam-review-node-maturity (node) 264 | (-when-let* (((&alist "MATURITY" maturity) (org-roam-node-properties node))) 265 | (intern maturity))) 266 | 267 | (defun org-roam-review-node-list () 268 | "Return all org-roam-nodes that are not explicitly ignored from reviews." 269 | (let ((table (ht-create))) 270 | (dolist (node (org-roam-node-list)) 271 | (unless (org-roam-review-node-ignored-p node) 272 | (ht-set table (org-roam-node-id node) node))) 273 | (ht-values table))) 274 | 275 | 276 | ;;; Review buffers 277 | 278 | (defmacro org-roam-review--with-current-review-buffer (&rest body) 279 | (declare (indent 0)) 280 | `(if-let* ((buf (car (org-roam-review-buffers)))) 281 | (with-current-buffer buf 282 | ;; KLUDGE: Suppress warnings from org-element about this being a 283 | ;; non-org-mode buffer. 284 | (let ((major-mode 'org-mode)) 285 | ,@body)) 286 | (error "No review buffer"))) 287 | 288 | (defun org-roam-review--daily-file-p (&optional file) 289 | "Test whether FILE is a daily node. 290 | 291 | If FILE is not given, checks the current buffer. 292 | 293 | This is a wrapper that makes sure `org-roam-directory' is well-formed. 294 | 295 | See: 296 | https://github.com/org-roam/org-roam/issues/2032" 297 | (cl-assert (or file (buffer-file-name))) 298 | (let ((org-roam-directory (string-remove-suffix org-roam-dailies-directory org-roam-directory))) 299 | (org-roam-dailies--daily-note-p file))) 300 | 301 | (defun org-roam-review--tags-at-pt (&optional local) 302 | (seq-map #'substring-no-properties 303 | (if (org-before-first-heading-p) 304 | org-file-tags 305 | (org-get-tags nil local)))) 306 | 307 | (defvar-local org-roam-review-buffer-refresh-command nil) 308 | 309 | (defun org-roam-review-buffers () 310 | (seq-filter (lambda (buf) 311 | (and (buffer-live-p buf) 312 | (with-current-buffer buf 313 | (derived-mode-p 'org-roam-review-mode)))) 314 | (buffer-list))) 315 | 316 | (defun org-roam-review-refresh (&optional interactive-p) 317 | "Rebuild the review buffer. 318 | 319 | INTERACTIVE-P indicates that the function was called 320 | interactively. Extra messages will be logged." 321 | (interactive "P") 322 | (dolist (buf (org-roam-review-buffers)) 323 | (with-current-buffer buf 324 | (unless org-roam-review-buffer-refresh-command 325 | (error "Refresh command not defined")) 326 | (funcall org-roam-review-buffer-refresh-command))) 327 | (when interactive-p 328 | (message "Buffer refreshed"))) 329 | 330 | (defun org-roam-review-modify-tags (tags-filter &optional no-refresh) 331 | "Read tags filter interactively. 332 | 333 | TAGS-FILTER is plist of type `org-tags-filter'. 334 | 335 | NO-REFRESH means don't update open org-roam-review buffers. 336 | 337 | When called with a `C-u' prefix arg, clear the current filter." 338 | (interactive (list 339 | (unless current-prefix-arg 340 | (org-tags-filter-read)))) 341 | (setq org-tags-filter-last-value tags-filter) 342 | (unless no-refresh 343 | (org-roam-review-refresh t))) 344 | 345 | (defvar org-roam-review-mode-map 346 | (let ((keymap (make-sparse-keymap))) 347 | (define-key keymap (kbd "/") #'org-roam-review-modify-tags) 348 | (define-key keymap (kbd "TAB") #'magit-section-cycle) 349 | (define-key keymap (kbd "g") #'org-roam-review-refresh) 350 | (define-key keymap (kbd "a") #'org-roam-review-accept) 351 | (define-key keymap (kbd "u") #'org-roam-review-bury) 352 | (define-key keymap (kbd "x") #'org-roam-review-set-excluded) 353 | (define-key keymap [remap org-roam-buffer-refresh] #'org-roam-review-refresh) 354 | keymap)) 355 | 356 | (defun org-roam-review--refresh-buffer-override (fn &rest args) 357 | (if (equal (buffer-name) org-roam-buffer) 358 | (apply fn args) 359 | (call-interactively 'org-roam-review-refresh))) 360 | 361 | (define-derived-mode org-roam-review-mode org-roam-mode "Org-roam-review" 362 | "Major mode for displaying relevant information about Org-roam nodes for review." 363 | :group 'org-roam-review 364 | ;; HACK: avoid all calls to org-roam-buffer-review if we're in a review 365 | ;; buffer, since it will error. 366 | (advice-add 'org-roam-buffer-refresh :around #'org-roam-review--refresh-buffer-override)) 367 | 368 | (defvar org-roam-review-indent-width 2) 369 | 370 | (defun org-roam-review-indent-string (str depth) 371 | (replace-regexp-in-string (rx bol) (make-string (* depth org-roam-review-indent-width) 32) 372 | str)) 373 | 374 | (cl-defun org-roam-review-insert-preview (node &key point (depth 0)) 375 | (magit-insert-section section (org-roam-preview-section) 376 | (let* ((start (or point (org-roam-node-point node))) 377 | (file (org-roam-node-file node)) 378 | (preview (org-roam-fontify-like-in-org-mode (org-roam-preview-get-contents file start))) 379 | (post-formatters 380 | (append org-roam-preview-postprocess-functions 381 | (list (lambda (content) 382 | (org-roam-review-indent-string (if (string-blank-p (string-trim-left content)) 383 | (propertize "(Empty)" 'font-lock-face 'font-lock-comment-face) 384 | content) 385 | depth))))) 386 | (formatted-preview (seq-reduce (lambda (str fn) 387 | (save-match-data 388 | (save-excursion 389 | (funcall fn str)))) 390 | post-formatters 391 | preview))) 392 | (oset section file file) 393 | (oset section point start) 394 | (insert formatted-preview) 395 | (insert "\n\n")))) 396 | 397 | (defun org-roam-review-default-title-formatter (node) 398 | (propertize (org-roam-node-title node) 399 | 'font-lock-face 'magit-section-secondary-heading)) 400 | 401 | (defun org-roam-review--insert-node (node) 402 | (atomic-change-group 403 | (magit-insert-section section (org-roam-node-section (org-roam-node-id node) t) 404 | (magit-insert-heading (funcall org-roam-review-title-formatter node)) 405 | (oset section node node) 406 | ;; KLUDGE: Mofified macro-expansion of `magit-insert-section-body' that 407 | ;; avoids unsetting the parent section's keymap. 408 | (oset section washer 409 | (lambda () 410 | (org-roam-review-insert-preview node) 411 | (magit-section-maybe-remove-visibility-indicator section)))))) 412 | 413 | (defvar org-roam-review-default-placeholder 414 | (propertize "(None)" 'face 'font-lock-comment-face)) 415 | 416 | (defun org-roam-review--insert-nodes (nodes placeholder) 417 | (if nodes 418 | (--each (nreverse nodes) 419 | (org-roam-review--insert-node it)) 420 | (insert (or placeholder org-roam-review-default-placeholder)) 421 | (newline))) 422 | 423 | (plisty-define org-roam-review-render-args 424 | :optional (:group-on :nodes :placeholder :sort) 425 | :required (:root-section)) 426 | 427 | (defclass org-roam-review-grouping-section (magit-section) ()) 428 | 429 | (defalias 'org-roam-review--render 430 | (-lambda ((&plist :group-on :nodes :placeholder :sort :root-section)) 431 | (let ((sort (or sort (-const t)))) 432 | (cond 433 | ((null nodes) 434 | (insert (or placeholder org-roam-review-default-placeholder)) 435 | (newline)) 436 | (group-on 437 | (let ((grouped (->> (seq-group-by group-on nodes) 438 | (-sort (-on #'<= (-lambda ((key . _)) 439 | (if (stringp key) key (or (cdr key) 0)))))))) 440 | (pcase-dolist (`(,key . ,group) grouped) 441 | (when (and key group) 442 | (let ((header (format "%s (%s)" 443 | (if (stringp key) key (car key)) 444 | (length group)))) 445 | (magit-insert-section section (org-roam-review-grouping-section header) 446 | (oset section parent root-section) 447 | (magit-insert-heading (propertize header 'font-lock-face 'magit-section-heading)) 448 | (org-roam-review--insert-nodes (-sort sort group) placeholder) 449 | (insert "\n"))))))) 450 | (t 451 | (org-roam-review--insert-nodes (-sort sort nodes) placeholder)))))) 452 | 453 | (cl-defun org-roam-review--re-render (&key render title instructions group-on placeholder sort nodes) 454 | (let ((inhibit-read-only t)) 455 | (erase-buffer) 456 | (org-roam-review-mode) 457 | (org-roam-buffer-set-header-line-format title) 458 | (magit-insert-section root-section (root) 459 | (when (and org-roam-review-show-instructions-p instructions nodes) 460 | (let ((start (point))) 461 | (insert (propertize instructions 'font-lock-face 'org-roam-review-instructions)) 462 | (fill-region start (point))) 463 | (newline 2)) 464 | 465 | (let ((forbidden-tags (seq-map (lambda (it) (format "-%s" it)) (org-tags-filter-forbidden org-tags-filter-last-value))) 466 | (required-tags (seq-map (lambda (it) (format "+%s" it)) (org-tags-filter-required org-tags-filter-last-value)))) 467 | (when (or forbidden-tags required-tags) 468 | (insert (concat (propertize "Filters:" 'face 'org-roam-review-tags-filter-keyword) 469 | " " 470 | (propertize (string-join (append forbidden-tags required-tags) " ") 'face 'org-roam-review-tags-filter))) 471 | (newline 2))) 472 | 473 | (let ((start-of-content (point))) 474 | (funcall render 475 | (org-roam-review-render-args-create :nodes nodes 476 | :group-on group-on 477 | :sort sort 478 | :root-section root-section 479 | :placeholder placeholder)) 480 | (goto-char start-of-content))))) 481 | 482 | (cl-defun org-roam-review-create-buffer 483 | (&key title instructions group-on placeholder sort 484 | (nodes #'org-roam-review-node-list) 485 | (buffer-name "*org-roam-review*") 486 | (render 'org-roam-review--render)) 487 | "Create a buffer for displaying nodes via `magit-section'. 488 | 489 | The following keyword arguments are required: 490 | 491 | - TITLE is the header line for the buffer. 492 | 493 | - INSTRUCTIONS is a paragraph inserted below the title. It is 494 | automatically paragraph-filled. 495 | 496 | The following keyword arguments are optional: 497 | 498 | - NODES is a function returning a list of nodes to display (which 499 | is possibly empty). It defaults to all non-ignored nodes. 500 | 501 | - PLACEHOLDER is a string to be shown if there are no nodes to 502 | display. 503 | 504 | - BUFFER-NAME is the name to use for the created buffer. 505 | 506 | - RENDER is a function taking a single argument, a plist of type 507 | `org-roam-review-render-args', that populates the buffer using 508 | the magit-section API. It can be used to override the default 509 | rendering behaviour. 510 | 511 | - GROUP-ON is a projection function that is passed a node and 512 | should return one of: 513 | 514 | - nil, meaning the node should be omitted 515 | 516 | - a string to use for grouping the node 517 | 518 | - a cons of `(GROUP-NAME . GROUP-PRIORITY)', where: 519 | 520 | - GROUP-NAME is the string for grouping the node 521 | 522 | - GROUP-PRIORITY is a number used to order group in the 523 | buffer. 524 | 525 | - SORT is a projection function that is passed two nodes within a 526 | group and returns non-nil if the first element should sort 527 | before the second." 528 | (cl-assert title) 529 | (cl-assert (functionp nodes)) 530 | (let (re-render) 531 | (setq re-render 532 | (lambda (updated-nodes) 533 | (with-current-buffer (get-buffer-create buffer-name) 534 | (org-roam-review--re-render :title title 535 | :instructions instructions 536 | :nodes updated-nodes 537 | :group-on group-on 538 | :placeholder placeholder 539 | :sort sort 540 | :render render) 541 | (setq-local org-roam-review-buffer-refresh-command (lambda () (funcall re-render (funcall nodes)))) 542 | (current-buffer)))) 543 | (funcall re-render (funcall nodes)))) 544 | 545 | ;;;###autoload 546 | (defun org-roam-review (&optional all) 547 | "List nodes that are due for review. 548 | 549 | With optional prefix arg ALL, list all evergreen nodes 550 | categorised by their maturity." 551 | (interactive "P") 552 | (if all 553 | (org-roam-review-list-by-maturity) 554 | (org-roam-review-list-due))) 555 | 556 | (defun org-roam-review--maturity-header (node) 557 | (if (member "memo" (org-roam-node-tags node)) 558 | (cons "Memorise 💭" 0) 559 | (pcase (org-roam-review-node-maturity node) 560 | ('seedling (cons "Seedling 🌱" 3)) 561 | ('budding (cons "Budding 🪴" 2)) 562 | ('evergreen (cons "Evergreen 🌲" 1)) 563 | (value value)))) 564 | 565 | (defun org-roam-review-node-due-p (node) 566 | (when-let* ((next-review (org-roam-review-node-next-review node))) 567 | (ts<= next-review (ts-now)))) 568 | 569 | ;;;###autoload 570 | (defun org-roam-review-list-due () 571 | "List nodes that are due for review." 572 | (interactive) 573 | (display-buffer 574 | (org-roam-review-create-buffer 575 | :title "Due Notes" 576 | :instructions "The nodes below are due for review. 577 | Read each node and add new thoughts and connections, then mark 578 | them as reviewed with `org-roam-review-accept', 579 | `org-roam-review-bury' or by updating their maturity." 580 | :placeholder (concat (propertize "You're up-to-date!" 'face 'font-lock-comment-face) " 😸") 581 | :group-on #'org-roam-review--maturity-header 582 | :sort (-on #'ts< #'org-roam-review-node-next-review) 583 | :nodes 584 | (lambda () 585 | (seq-filter (lambda (node) 586 | (and (zerop (org-roam-node-level node)) 587 | (null (seq-intersection (org-roam-node-tags node) 588 | org-roam-review-tags-ignored-for-review-buffer)) 589 | (org-roam-review-node-due-p node))) 590 | (org-roam-review-node-list)))))) 591 | 592 | (defalias 'org-roam-review-sort-by-title-case-insensitive 593 | (-on #'string-greaterp (-compose #'downcase #'org-roam-node-title))) 594 | 595 | ;;;###autoload 596 | (defun org-roam-review-list-by-maturity () 597 | "List all evergreen nodes categorised by maturity." 598 | (interactive) 599 | (display-buffer 600 | (org-roam-review-create-buffer 601 | :title "Evergreen Notes" 602 | :instructions "The nodes below are categorised by maturity." 603 | :group-on #'org-roam-review--maturity-header 604 | :sort #'org-roam-review-sort-by-title-case-insensitive))) 605 | 606 | (defun org-roam-review--node-added-group (node) 607 | (when-let* ((created (org-roam-review-node-created-at node)) 608 | (recently (ts-adjust 'hour -24 (ts-now)))) 609 | (cond 610 | ((ts<= recently created) 611 | (cons "Recent" 1)) 612 | ((ts<= (ts-adjust 'day -3 recently) created) 613 | (cons "Last 3 days" 2)) 614 | ((ts<= (ts-adjust 'day -7 recently) created) 615 | (cons "Last week" 3))))) 616 | 617 | ;;;###autoload 618 | (defun org-roam-review-list-recently-added () 619 | "List nodes that were created recently, grouped by time." 620 | (interactive) 621 | (display-buffer 622 | (org-roam-review-create-buffer 623 | :title "Recently Created Notes" 624 | :instructions "The nodes below are sorted by when they were created." 625 | :group-on #'org-roam-review--node-added-group 626 | :sort #'org-roam-review-sort-by-title-case-insensitive))) 627 | 628 | 629 | ;;; Commands for manipulating node review state. 630 | 631 | (defun org-roam-review--update-workspace-for-completed-review () 632 | (when-let* ((buf (get-buffer "*org-roam-review*"))) 633 | (display-buffer buf))) 634 | 635 | (defmacro org-roam-review--visiting-node-at-point (&rest body) 636 | (declare (indent 0)) 637 | `(let* ((node (org-roam-node-at-point t)) 638 | (file (org-roam-node-file node))) 639 | (cond 640 | (file 641 | (with-current-buffer (find-file-noselect file) 642 | (save-excursion 643 | (goto-char (org-roam-node-point node)) 644 | ,@body))) 645 | ((derived-mode-p 'org-mode) 646 | (org-with-wide-buffer 647 | (point-min) 648 | ,@body)) 649 | (t 650 | (error "Invalid context for visiting node"))) 651 | node)) 652 | 653 | (defun org-roam-review--in-multiwindow-session-p () 654 | (and (< 1 (length (window-list))) 655 | (seq-find (lambda (it) (equal (get-buffer "*org-roam-review*") (window-buffer it))) 656 | (window-list)))) 657 | 658 | (defun org-roam-review-open-node-if-in-review-session () 659 | (when (org-roam-review--in-multiwindow-session-p) 660 | (when-let* ((node (org-roam-node-at-point))) 661 | (org-roam-node-visit node)))) 662 | 663 | (defun org-roam-review--forward-to-uncommented-sibling () 664 | (ignore-errors 665 | (let ((section (magit-current-section)) 666 | (stop) 667 | (found)) 668 | (while (not stop) 669 | (magit-section-forward-sibling) 670 | ;; Skip over group headlines 671 | (magit-section-case 672 | (org-roam-review-grouping-section 673 | (magit-section-forward))) 674 | 675 | (setq found (not (equal 'font-lock-comment-face (get-text-property (point) 'face)))) 676 | (let ((unchanged (equal (magit-current-section) section))) 677 | (setq stop (or found unchanged)))) 678 | found))) 679 | 680 | (defun org-roam-review--update-review-buffer-entry (node) 681 | ;; Nothing to do if there are no review buffers. 682 | (when (org-roam-review-buffers) 683 | (org-roam-review--with-current-review-buffer 684 | (let ((continue t) 685 | (found-pos nil) 686 | (id (org-roam-node-id node))) 687 | (save-excursion 688 | (goto-char (point-min)) 689 | (while (and (not found-pos) continue) 690 | (if (equal id (ignore-errors (org-roam-node-id (org-roam-node-at-point)))) 691 | (setq continue nil 692 | found-pos (point)) 693 | (or (ignore-errors (magit-section-forward) t) 694 | (setq continue nil))))) 695 | 696 | (when found-pos 697 | (goto-char found-pos) 698 | (when-let* ((section (magit-current-section))) 699 | (when (oref section node) 700 | (let ((inhibit-read-only t)) 701 | (put-text-property (line-beginning-position) (line-end-position) 'face 'font-lock-comment-face)) 702 | (magit-section-hide section)))))))) 703 | 704 | (defmacro org-roam-review--transform-selected-sections (&rest body) 705 | "Execute BODY, possibly over multiple sections. 706 | 707 | Return the affected sections." 708 | (declare (indent 0)) 709 | `(progn 710 | (if-let* ((sections (-list (or (magit-region-sections) (magit-section-at))))) 711 | (dolist (section sections) 712 | (goto-char (oref section start)) 713 | (let ((buf (current-buffer)) 714 | (result (progn ,@body))) 715 | (when (buffer-live-p buf) 716 | (with-current-buffer buf 717 | (deactivate-mark) 718 | (magit-section-deactivate-mark) 719 | (magit-section-update-highlight))) 720 | result)) 721 | ,@body) 722 | 723 | (when (org-roam-review-buffers) 724 | (org-roam-review--with-current-review-buffer 725 | (when (org-roam-review--forward-to-uncommented-sibling) 726 | (run-hooks 'org-roam-review-next-node-selected-hook)))))) 727 | 728 | (defun org-roam-review--maybe-kill-reviewed-buffer (buf) 729 | (when (and org-roam-review-kill-reviewed-buffers-p (buffer-live-p buf)) 730 | (with-current-buffer buf 731 | (save-buffer) 732 | (kill-buffer)))) 733 | 734 | ;;;###autoload 735 | (defun org-roam-review-accept () 736 | "Confirm review of the current node." 737 | (interactive) 738 | (let ((count 0)) 739 | (org-roam-review--transform-selected-sections 740 | (cl-incf count) 741 | (let ((node (org-roam-review--visiting-node-at-point 742 | (org-roam-review--update-node-srs-properties org-roam-review--maturity-score-ok 743 | (org-entry-get-with-inheritance "MATURITY")) 744 | (let ((buf (current-buffer))) 745 | (run-hooks 'org-roam-review-node-accepted-hook) 746 | (run-hooks 'org-roam-review-node-processed-hook) 747 | (org-roam-review--maybe-kill-reviewed-buffer buf))))) 748 | (org-roam-review--update-review-buffer-entry node))) 749 | (message "Node%s scheduled for future review" (if (= 1 count) "" "s")))) 750 | 751 | ;;;###autoload 752 | (defun org-roam-review-forgot () 753 | "Mark the current node as requiring review again soon." 754 | (interactive) 755 | (let ((count 0)) 756 | (org-roam-review--transform-selected-sections 757 | (cl-incf count) 758 | (let ((node (org-roam-review--visiting-node-at-point 759 | (org-roam-review--update-node-srs-properties org-roam-review--maturity-score-revisit 760 | (org-entry-get-with-inheritance "MATURITY")) 761 | (let ((buf (current-buffer))) 762 | (run-hooks 'org-roam-review-node-forgotten-hook) 763 | (run-hooks 'org-roam-review-node-processed-hook) 764 | (org-roam-review--maybe-kill-reviewed-buffer buf))))) 765 | (org-roam-review--update-review-buffer-entry node))) 766 | (message "Node%s scheduled for review again soon" (if (= 1 count) "" "s")))) 767 | 768 | ;;;###autoload 769 | (defun org-roam-review-bury () 770 | "Confirm review of the current node and bury it." 771 | (interactive) 772 | (let ((count 0)) 773 | (org-roam-review--transform-selected-sections 774 | (cl-incf count) 775 | (let ((node (org-roam-review--visiting-node-at-point 776 | (org-roam-review--update-node-srs-properties org-roam-review--maturity-score-bury 777 | (org-entry-get-with-inheritance "MATURITY")) 778 | (let ((buf (current-buffer))) 779 | (run-hooks 'org-roam-review-node-buried-hook) 780 | (run-hooks 'org-roam-review-node-processed-hook) 781 | (org-roam-review--maybe-kill-reviewed-buffer buf))))) 782 | (org-roam-review--update-review-buffer-entry node))) 783 | (message "Node%s buried" (if (= 1 count) "" "s")))) 784 | 785 | (defun org-roam-review--skip-node-for-maturity-assignment-p () 786 | (org-with-wide-buffer 787 | (or (org-roam-review--daily-file-p (buffer-file-name)) 788 | (seq-intersection org-roam-review-ignored-tags (org-roam-review--tags-at-pt))))) 789 | 790 | ;;;###autoload 791 | (defun org-roam-review-set-memorise () 792 | "Set the current node as a 'memorise' node. 793 | 794 | It will show up in a dedicated section of the review buffer when it's due." 795 | (interactive) 796 | (org-roam-review--transform-selected-sections 797 | (let ((node (org-roam-review--visiting-node-at-point 798 | (ignore-errors 799 | (org-roam-tag-remove org-roam-review-maturity-values)) 800 | (org-roam-tag-add (list "memo")) 801 | (org-delete-property "MATURITY") 802 | (org-roam-review--update-node-srs-properties org-roam-review--maturity-score-revisit)))) 803 | (org-roam-review--update-review-buffer-entry node) 804 | (when org-roam-review-memo-slipbox 805 | (unless (equal org-roam-review-memo-slipbox (org-roam-node-slipbox node)) 806 | (org-roam-slipbox-refile node org-roam-review-memo-slipbox)))))) 807 | 808 | ;;;###autoload 809 | (defun org-roam-review-set-budding (&optional bury) 810 | "Set the current node as a 'budding' node and confirm it's been reviewed. 811 | 812 | With prefix arg BURY, the node is less likely to be surfaced in 813 | the future." 814 | (interactive "P") 815 | (org-roam-review--transform-selected-sections 816 | (let* ((score (if bury 817 | org-roam-review--maturity-score-bury 818 | org-roam-review--maturity-score-ok)) 819 | (node (org-roam-review--visiting-node-at-point 820 | (unless (org-roam-review--skip-node-for-maturity-assignment-p) 821 | (org-roam-review--update-node-srs-properties score "budding"))))) 822 | (org-roam-review--update-review-buffer-entry node)))) 823 | 824 | ;;;###autoload 825 | (defun org-roam-review-set-seedling (&optional bury) 826 | "Set the current node as a 'seedling' node and confirm it's been reviewed. 827 | 828 | With prefix arg BURY, the node is less likely to be surfaced in 829 | the future." 830 | (interactive "P") 831 | (org-roam-review--transform-selected-sections 832 | (let* ((score (if bury 833 | org-roam-review--maturity-score-bury 834 | org-roam-review--maturity-score-revisit)) 835 | (node (org-roam-review--visiting-node-at-point 836 | (unless (org-roam-review--skip-node-for-maturity-assignment-p) 837 | (org-roam-review--update-node-srs-properties score "seedling"))))) 838 | (org-roam-review--update-review-buffer-entry node)))) 839 | 840 | ;;;###autoload 841 | (defun org-roam-review-set-evergreen (&optional bury) 842 | "Set the current node as an 'evergreen' node and confirm it's been reviewed. 843 | 844 | With prefix arg BURY, the node is less likely to be surfaced in 845 | the future." 846 | (interactive "P") 847 | (org-roam-review--transform-selected-sections 848 | (let* ((score (if bury 849 | org-roam-review--maturity-score-bury 850 | org-roam-review--maturity-score-ok)) 851 | (node (org-roam-review--visiting-node-at-point 852 | (unless (org-roam-review--skip-node-for-maturity-assignment-p) 853 | (org-roam-review--update-node-srs-properties score "evergreen"))))) 854 | (org-roam-review--update-review-buffer-entry node)))) 855 | 856 | (defun org-roam-review--delete-tags-and-properties (node-id) 857 | (let ((message-log-max)) 858 | (org-with-point-at (org-find-property "ID" node-id) 859 | (atomic-change-group 860 | (ignore-errors 861 | (org-roam-tag-remove org-roam-review-maturity-values)) 862 | (dolist (name org-roam-review-properties) 863 | (org-delete-property name)))))) 864 | 865 | ;;;###autoload 866 | (defun org-roam-review-set-excluded () 867 | "Exclude this node from reviews. 868 | 869 | This deletes all the properties and tags managed by this 870 | package." 871 | (interactive) 872 | (let ((titles)) 873 | (org-roam-review--transform-selected-sections 874 | (let ((node (org-roam-review--visiting-node-at-point 875 | (let ((id (org-entry-get (point-min) "ID"))) 876 | (unless id 877 | (error "No ID in buffer")) 878 | (org-with-point-at (org-find-property "ID" id) 879 | (org-roam-review--delete-tags-and-properties id) 880 | (save-buffer)) 881 | (let ((title (org-roam-node-title (org-roam-node-from-id id)))) 882 | (push title titles)))))) 883 | 884 | (org-roam-review--update-review-buffer-entry node))) 885 | 886 | (if (equal 1 (length titles)) 887 | (message "Excluded node `%s' from reviews" (car titles)) 888 | (message "Excluded %s nodes from reviews" (length titles))))) 889 | 890 | (provide 'org-roam-review) 891 | 892 | ;;; org-roam-review.el ends here 893 | --------------------------------------------------------------------------------