diff options
Diffstat (limited to 'seam.el')
| -rw-r--r-- | seam.el | 568 |
1 files changed, 568 insertions, 0 deletions
@@ -0,0 +1,568 @@ +;;; seam.el --- Personal Org mode wiki -*- lexical-binding: t; -*- + +;; Copyright (c) 2025 Spencer Williams + +;; Author: Spencer Williams <spnw@plexwave.org> +;; Homepage: https://wiki.plexwave.org/seam +;; Keywords: hypermedia, outlines + +;; Version: 0.1.0 + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Seam is a package that lets you easily create, link, and publish +;; Org notes in the form of a personal wiki. + +;;; Code: + +(require 'seam-export) +(require 'cl-lib) +(require 'grep) + +(defgroup seam nil + "Options for Seam." + :group 'org + :tag "Seam") + +(defcustom seam-note-directory nil + "Seam note directory." + :group 'seam + :type '(choice directory (const nil))) + +(defcustom seam-default-note-type "private" + "Default type for Seam notes." + :group 'seam + :type 'string) + +(defcustom seam-note-types '("private" "public") + "Seam note types." + :group 'seam + :type '(repeat string)) + +(defun seam-format-title-default (title type) + "Default Seam title formatter. Formats like this: \"TITLE (TYPE)\"." + (format "%s %s" title (propertize (format "(%s)" type) 'face 'font-lock-comment-face))) + +(defcustom seam-title-formatter + #'seam-format-title-default + "Function used by Seam to format note titles for completion and buffer +naming. Must be a function taking two arguments: TITLE and TYPE." + :group 'seam + :type 'function) + +(defun seam-html-directories () + (mapcar #'car seam-export-alist)) + +(defun seam-lookup-slug (slug) + (cl-dolist (type seam-note-types) + (let ((file (file-name-concat seam-note-directory type (concat slug ".org")))) + (when (file-exists-p file) + (cl-return (expand-file-name file)))))) + +(defun seam--check-conflict (title) + (when (seam-lookup-slug (seam-slugify title)) + (error "`%s' would conflict with an existing note" title))) + +(defun seam-link-open (path _prefix) + (org-mark-ring-push) + (if-let ((file (seam-lookup-slug path))) + (find-file file) + (seam-make-note path nil t)) + (seam-set-buffer-name)) + +(defvar seam-note-file-regexp "\\`[^.].+\\.org\\'") +(defvar seam--subset nil) + +(defcustom seam-completing-read-function #'completing-read + "The completion function used by Seam." + :group 'seam + :type 'function) + +(defun seam-ensure-directory-exists (dir) + (unless (file-directory-p dir) + (make-directory dir t))) + +(defun seam-ensure-note-subdirectories-exist () + (unless seam-note-directory + (error "Please set `seam-note-directory'")) + (cl-dolist (type seam-note-types) + (let ((dir (file-name-concat seam-note-directory type))) + (seam-ensure-directory-exists dir)))) + +(defcustom seam-sort-method 'title + "The method used by Seam to sort notes." + :group 'seam + :type '(choice (const :tag "Sort by title" title) + (const :tag "Sort by modification date" modified))) + +(cl-defgeneric seam-get-all-notes (sort-by)) + +(cl-defmethod seam-get-all-notes ((sort-by (eql 't))) + (ignore sort-by) + (seam-get-all-notes seam-sort-method)) + +(cl-defmethod seam-get-all-notes ((sort-by (eql 'modified))) + (ignore sort-by) + (let ((files (cl-loop for type in (seam--active-subset) + append (directory-files-and-attributes + (file-name-concat seam-note-directory type) + t + seam-note-file-regexp)))) + (cl-loop for (file . _attributes) + in (cl-sort + files + (lambda (f1 f2) + (time-less-p (file-attribute-modification-time f2) + (file-attribute-modification-time f1))) + :key #'cdr) + collect (cons (seam-get-title-from-file file) file)))) + +(cl-defmethod seam-get-all-notes ((sort-by (eql 'title))) + (ignore sort-by) + (let ((files (cl-loop for type in (seam--active-subset) + append (directory-files + (file-name-concat seam-note-directory type) + t + seam-note-file-regexp)))) + (cl-sort + (cl-loop for file in files + collect (cons (seam-get-title-from-file file) file)) + #'string< + :key #'car))) + +(cl-defun seam-get-title-from-buffer (&optional (buffer (current-buffer))) + (with-current-buffer buffer + (save-mark-and-excursion + (save-restriction + (goto-char 1) + (ignore-errors + (re-search-forward (org-headline-re 1)) + (let ((start (point))) + (end-of-line) + (let ((title (string-trim (buffer-substring-no-properties start (point))))) + (unless (string-empty-p title) + title)))))))) + +(defun seam-get-title-from-file (file) + (with-temp-buffer + (insert-file-contents file) + (seam-get-title-from-buffer))) + +(defun seam-format-title (title type) + (funcall seam-title-formatter title type)) + +(defun seam--completing-read (&rest args) + (let ((completion-ignore-case t)) + (apply seam-completing-read-function args))) + +(defun seam-slugify (title) + (downcase (string-join (string-split title "\\W+" t) "-"))) + +(defun seam-make-note (title &optional type select) + (unless type + (setq type seam-default-note-type)) + (unless (member type seam-note-types) + (error "`%s' is not a valid Seam note type" type)) + (seam-ensure-note-subdirectories-exist) + (let ((file (file-name-concat seam-note-directory + type + (concat (seam-slugify title) ".org")))) + (seam--check-conflict title) + (let ((buffer (funcall (if select #'find-file #'find-file-noselect) file))) + (with-current-buffer buffer + (insert (format "* %s\n" title)) + (save-buffer) + buffer)))) + +(defun seam-read-title (prompt) + (seam-ensure-note-subdirectories-exist) + (let* ((notes (seam-get-all-notes t)) + (self (cl-find (buffer-file-name) notes :key #'cdr :test #'equal))) + (let ((notes + (append (cl-remove self + notes + :test #'equal) + (and self (list self))))) + (let ((files (cl-loop for (title . file) in notes + collect (cons (seam-format-title title (seam-get-note-type file)) file)))) + (let ((completion (string-trim (seam--completing-read prompt files)))) + (or (assoc completion files) + (cons completion nil))))))) + +(defun seam--read-type (prompt arg &optional choices) + (when arg + (if (listp arg) + (seam--completing-read prompt (or choices seam-note-types) nil t) + (nth (1- arg) seam-note-types)))) + +;;;###autoload +(defun seam-find-note (arg) + "Find Seam note interactively by title, creating it if it does not exist. +`seam-completing-read-function' is used for completion. + +A prefix argument can be used to show only a specific note type (and to +use that type if a new note is created). With a numeric argument N, the +Nth type in `seam-note-types' is chosen (counting from 1). With C-u, a +completion prompt is given to choose the type." + (interactive "P") + (let* ((type (seam--read-type "Type: " arg)) + (seam--subset + (if type (list type) seam-note-types))) + (cl-destructuring-bind (completion . file) + (seam-read-title "Open note: ") + (if file + (with-current-buffer (find-file file) + ;; Ensure buffer name is up to date (e.g. after changing + ;; formatter function) (NOTE: Redundant if buffer wasn't + ;; already open, as `seam-setup-buffer' does this too.) + (seam-set-buffer-name)) + (seam-make-note (string-trim completion) (or type seam-default-note-type) t))))) + +(cl-defun seam-get-note-type (file &optional no-error) + (when (and file (equal "org" (file-name-extension file))) + (let ((type (cadr (nreverse (file-name-split file))))) + (when (member type seam-note-types) + (cl-return-from seam-get-note-type type)))) + (unless no-error + (error "%s is not a Seam note" file))) + +(defun seam-make-file-name (slug type) + (expand-file-name + (file-name-concat + seam-note-directory type + (concat slug ".org")))) + +(defun seam-get-links-to-file (file) + "Return filename of each note which links to FILE." + (remove (expand-file-name file) + (seam-note-files-containing-string (format "[[seam:%s]" (file-name-base file))))) + +(defun seam-get-links-from-file (file) + "Return filename of each existing note which is linked to from FILE." + (let ((links + (with-temp-buffer + (insert-file-contents file) + (delete-dups + (cl-loop for ret = (re-search-forward "\\[\\[seam:\\(.*?\\)\\]" nil t) + while ret collect (match-string 1)))))) + (remove (expand-file-name file) + (cl-loop for link in links + as f = (seam-lookup-slug link) + when f collect f)))) + +(defun seam-delete-html-files-for-note (note-file) + (dolist (dir (seam-html-directories)) + (let ((html (file-name-concat dir (concat (file-name-base note-file) ".html")))) + (when (file-exists-p html) + (delete-file html) + (message "Deleted %s" html))))) + +(defun seam-post-save-or-rename (old new &optional previous-links-from-file) + (unless (string= old new) + (seam-update-links old new) + (seam-delete-html-files-for-note old) + (dolist (dir (seam-html-directories)) + (delete-file (file-name-concat dir (concat (file-name-base old) ".html"))))) + (seam-export-note new) + (let ((removed-links (cl-set-difference previous-links-from-file + (seam-get-links-from-file new) + :test #'string=))) + (mapc #'seam-export-note + (delete-dups + (append removed-links + (seam-get-links-from-file new) + ;; If our type changes, we cannot rely on + ;; `seam-update-links' to trigger a re-render of + ;; the pages that link to us, as types are not + ;; encoded in the link. + (unless (string= (seam-get-note-type old) + (seam-get-note-type new)) + (seam-get-links-to-file new))))))) + +(defun seam-save-buffer () + (let* ((old (buffer-file-name)) + (type (seam-get-note-type old t))) + (when type + (let* ((title (or (seam-get-title-from-buffer) + (error "Note must have a title"))) + (slug (seam-slugify title)) + (new (seam-make-file-name slug type))) + (unless (string= old new) ;This is valid because + ;`seam-save-buffer' cannot + ;change type. + (seam--check-conflict title) + (rename-file old new) + (set-visited-file-name new nil t)) + (let ((previous-links-from-file + ;; If we've yet to create the file, don't check it. + (when (file-exists-p new) + (seam-get-links-from-file new)))) + (let ((write-contents-functions + (remove 'seam-save-buffer write-contents-functions))) + (save-buffer)) + (seam-post-save-or-rename old new previous-links-from-file) + (seam-set-buffer-name) + t))))) + +(defun seam--set-note-type (file new-type) + (let ((old-type (seam-get-note-type file)) + (new-file (seam-make-file-name (file-name-base file) new-type))) + (if (string= new-type old-type) + file + (rename-file file new-file) + (seam-post-save-or-rename file new-file) + new-file))) + +;;;###autoload +(defun seam-set-note-type (file new-type &optional interactive) + "Set Seam note FILE to NEW-TYPE. Error if file is not a Seam note. + +When called interactively, FILE is the currently visited file. A +numeric argument N chooses the Nth type in `seam-note-types' (counting +from 1). Otherwise a completion prompt is given for the desired type." + (interactive + (let* ((file (buffer-file-name)) + (old-type (seam-get-note-type file))) + (list file + (or (seam--read-type "New type: " + ;; HACK: Treat nil prefix as C-u. + (or current-prefix-arg '(4)) + (remove old-type seam-note-types)) + old-type) + t))) + (let ((new-file (seam--set-note-type file new-type))) + (when interactive + (set-visited-file-name new-file nil t) + (seam-set-buffer-name)))) + +(defun seam-update-links (old new) + (let ((old-slug (file-name-base old)) + (new-slug (file-name-base new))) + (unless (string= old-slug new-slug) + (let ((count (seam-replace-string-in-notes + (format "[[seam:%s]" old-slug) + (format "[[seam:%s]" new-slug) + t))) + (unless (zerop count) + (message "Updated links in %d file%s" + count (if (= count 1) "" "s"))))))) + +(defun seam--active-subset () + (or seam--subset seam-note-types)) + +(defun seam-note-subdirectories () + (cl-loop for type in (seam--active-subset) + collect (expand-file-name + (file-name-as-directory + (file-name-concat seam-note-directory type))))) + +(defun seam-note-files-containing-string (string) + "Search all Seam note files for literal STRING. Case-sensitive." + (seam-ensure-note-subdirectories-exist) + (with-temp-buffer + (apply #'call-process find-program + nil t nil + (append + (seam-note-subdirectories) + (list "-type" "f" "-name" "*.org" "-and" "-not" "-name" ".*" + "-exec" grep-program "-F" "-l" "-s" "-e" string "{}" "+"))) + (string-lines (string-trim (buffer-string)) t))) + +;;;###autoload +(defun seam-search (query &optional delimited) + "Search all Seam notes for the regexp QUERY (case-insensitively). If +DELIMITED is non-nil, only search at word boundaries. + +When called interactively, DELIMITED is t if a prefix argument is given. +Otherwise, it's nil." + (interactive (list (read-string (format "Search all notes%s: " + (if current-prefix-arg + " for word" + ""))) + current-prefix-arg)) + (when (eq grep-highlight-matches 'auto-detect) + (grep-compute-defaults)) + (let ((default-directory seam-note-directory)) + (grep + (format "%s %s -type f -name %s -and -not -name %s -exec %s %s -n -i -e %s \\{\\} \\+" + find-program + (string-join (mapcar (lambda (type) + (shell-quote-argument (concat type "/"))) + seam-note-types) + " ") + (shell-quote-argument "*.org") + (shell-quote-argument ".*") + grep-program + (if grep-highlight-matches "--color=always" "") + (shell-quote-argument + (if delimited + (concat "\\b" query "\\b") + query)))))) + +(defun seam-visited-files () + (cl-loop for buf in (buffer-list) + as file = (buffer-file-name buf) + when (and file (file-in-directory-p file seam-note-directory)) + collect file)) + +(defun seam-replace-string-in-notes (old new preserve-modtime) + (let ((hash (make-hash-table :test 'equal))) + (dolist (file (seam-note-files-containing-string old)) + (puthash file nil hash)) + (dolist (file (seam-visited-files)) + (puthash file t hash)) + (let ((update-count 0)) + (maphash + (lambda (file was-open-p) + (with-current-buffer (find-file-noselect file) + (let ((was-modified-p (buffer-modified-p))) + (save-mark-and-excursion + (without-restriction + (goto-char (point-min)) + (let ((updated-p nil)) + (while (search-forward old nil t) + (setq updated-p t) + (replace-match new)) + (when updated-p + (setq update-count (1+ update-count)))))) + (when (and (not was-modified-p) + (buffer-modified-p)) + (if preserve-modtime + (let ((modtime (visited-file-modtime))) + (save-buffer) + (set-file-times file modtime) + (set-visited-file-modtime modtime)) + (save-buffer))) + (unless was-open-p + (kill-buffer))))) + hash) + update-count))) + +(cl-defun seam-set-buffer-name (&optional (buffer (current-buffer))) + (with-current-buffer buffer + (rename-buffer + (seam-format-title (seam-get-title-from-buffer) + (seam-get-note-type (buffer-file-name buffer)))))) + +(defun seam-setup-buffer () + "Setup hooks when loading a Seam file." + (add-hook 'write-contents-functions 'seam-save-buffer nil t) + ;; NOTE: Needed for when note w/o using Seam commands. Redundant otherwise. + (seam-set-buffer-name)) + +(defun seam--watch-note-directory-var (_symbol newval operation _where) + "Install necessary hooks when `seam-note-directory' is set, removing any +old ones." + (when (member operation '(set makunbound)) + (setq dir-locals-directory-cache + (cl-remove 'seam-note-directory dir-locals-directory-cache :key #'cadr)) + (when newval + (dir-locals-set-directory-class newval 'seam-note-directory)))) + +(defun seam--delete-note (file) + (seam-get-note-type file) ;Error if file isn't a Seam note. + (let ((to-update (delete-dups + (append + (seam-get-links-to-file file) + (seam-get-links-from-file file))))) + (delete-file file t) + (seam-delete-html-files-for-note file) + (mapc #'seam-export-note to-update))) + +;;;###autoload +(defun seam-delete-note (file &optional interactive) + "Delete Seam note FILE. Error if file is not a Seam note. +`delete-by-moving-to-trash' is respected. + +When called interactively, FILE is the currently visited file, and the +buffer is killed after deletion." + (interactive + (let ((file (buffer-file-name))) + (seam-get-note-type file) ;Error if file isn't a Seam note. + (list + (let ((incoming (length (seam-get-links-to-file file)))) + (and (yes-or-no-p + (format "Really %s file and kill buffer%s?" + (if delete-by-moving-to-trash + "trash" + "delete") + (if (> incoming 0) + (format " (breaking links from %d note%s)" + incoming + (if (= incoming 1) "" "s")) + ""))) + file)) + t))) + (unless (and interactive (null file)) + (seam--delete-note file) + (when interactive + (kill-buffer)))) + +;;;###autoload +(defun seam-insert-link () + "Interactively insert an Org link at point to the given Seam note, +creating the note if it does not exist. If any text is selected, the +link will replace it." + (interactive) + (cl-destructuring-bind (completion . file) (seam-read-title "Insert link: ") + (let* ((new-buffer + (unless file + (seam-make-note completion seam-default-note-type nil))) + (selection (when (use-region-p) + (buffer-substring + (region-beginning) + (region-end)))) + (file (if new-buffer + (buffer-file-name new-buffer) + file)) + (slug (file-name-base file)) + (initial (or selection + (seam-get-title-from-file file))) + (desc (read-string "Description: " initial))) + (when selection + (delete-region (region-beginning) (region-end))) + (insert (format "[[seam:%s][%s]]" slug desc)) + (when new-buffer + (pop-to-buffer new-buffer))))) + +(defvar-keymap seam-prefix-map + "f" #'seam-find-note + "k" #'seam-delete-note + "l" #'seam-insert-link + "s" #'seam-search + "t" #'seam-set-note-type) + +(org-link-set-parameters "seam" :follow #'seam-link-open) + +(dir-locals-set-class-variables + 'seam-note-directory + '((org-mode . ((eval . (seam-setup-buffer)))))) + +(add-variable-watcher 'seam-note-directory #'seam--watch-note-directory-var) + +;;; If `seam-note-directory' was set before loading package, ensure +;;; directory class is set up. +(when (and seam-note-directory + (not (cl-find 'seam-note-directory dir-locals-directory-cache :key #'cadr))) + (dir-locals-set-directory-class seam-note-directory 'seam-note-directory)) + +(provide 'seam) + +;;; seam.el ends here |