path: root/seam.el

;;; 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-all-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-notes ()
  (let ((subdirs (seam-note-subdirectories)))
    (cl-loop for buf in (buffer-list)
             as file = (buffer-file-name buf)
             when (and file
                       (member (file-name-directory file) subdirs)
                       (string-match seam-note-file-regexp file))
             collect file)))

(defun seam-replace-string-in-all-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-notes))
      (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