org-node-context.el

;;; org-node-context.el --- Extension for displaying a buffer of backlinks  -*- lexical-binding: t; -*-

;; Copyright (C) 2025-2026 Martin Edström
;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Commentary:

;; Strictly an extension (core does not depend on this file).

;;; Code:

(declare-function org-entry-get-with-inheritance "org")
(declare-function org-at-comment-p "org")
(declare-function org-back-to-heading-or-point-min "org")
(require 'org-mem)
(require 'magit-section)
(require 'repeat)
(require 'map)
(require 'cond-let)
(require 'llama)
(eval-when-compile
  (require 'org)
  (require 'org-node)
  (require 'org-element))

(defgroup org-node-context nil "Preview backlink contexts in separate buffer."
  :group 'org-node)

(defun org-node-context--clean-stale-previews ()
  "Clean stale members in table `org-node-context--previews'."
  (let ((valid-positions (make-hash-table :test 'equal)))

    (maphash (lambda (pseudo-id links)
               (dolist (link links)
                 (push (org-mem-link-pos link)
                       (gethash (or (org-mem-link-nearby-id link) pseudo-id)
                                valid-positions))))
             org-mem--pseudo-id<>links)

    (maphash (lambda (key previews)
               (let ((entry (or (org-mem-entry-by-id key)
                                (org-mem-entry-by-pseudo-id key)))
                     (valid (gethash key valid-positions)))
                 (unless (and entry
                              (cl-loop
                               for (pos-diff . _text) in previews
                               always (memq (+ pos-diff (org-mem-entry-pos entry))
                                            valid)))
                   (remhash key org-node-context--previews))))
             org-node-context--previews)))


;;; Early defs

(defvar-keymap org-node-context-mode-map
  :parent magit-section-mode-map
  "<return>"                'org-node-context-visit-thing
  "C-m"                     'org-node-context-visit-thing
  "l"                       'org-node-context-history-go-back
  "r"                       'org-node-context-history-go-forward
  "<remap> <revert-buffer-quick>" 'org-node-context-refresh-this-buffer
  "<remap> <revert-buffer>"       'org-node-context-refresh-this-buffer)

(define-derived-mode org-node-context-mode magit-section-mode "Org-Node-Context"
  "Major mode for the context buffer."
  (when (or (member #'visual-line-mode org-mode-hook)
            (member #'visual-line-mode text-mode-hook))
    (visual-line-mode))
  ;; Ensure that Emacs will indeed render the font-locking done by
  ;; `org-node-context--get-preview'.
  ;; Magit-section normally disables it because:
  ;; https://github.com/magit/magit/commit/7de0f1335f8c4954d6d07413c5ec19fc8200078c
  (setq-local font-lock-defaults nil))

(defclass org-node-context (magit-section)
  ((value :initform nil)))


;;; History navigation

;; TODO
(defvar org-node-context--remembered-state (make-hash-table :test 'equal)
  "Table associating IDs with remembered context states.

A context for a given node ID is the entirety of what would be rendered
in the context buffer when that node is visited.

The context state is information about user-interactable elements the last
time that context was shown in a visible window.  Including:
- Where was point
- Window scroll position
- The array of backlinks shown, and which sections were collapsed")

(defvar-local org-node-context--current nil)
(defvar-local org-node-context--future nil)
(defvar-local org-node-context--past nil)

(defun org-node-context-history-go-back ()
  "Show the last context."
  (interactive () org-node-context-mode)
  (when-let ((last (pop org-node-context--past)))
    (push org-node-context--current
          org-node-context--future)
    (org-node-context--refresh nil last t)))

(defun org-node-context-history-go-forward ()
  "Show the next context."
  (interactive () org-node-context-mode)
  (when-let ((next (pop org-node-context--future)))
    (push org-node-context--current
          org-node-context--past)
    (org-node-context--refresh nil next t)))


;;; Porcelain

;; TODO: Simply check if the expanded sections would push 1 or more sections
;; below the visible window, and decide based on that.
(defcustom org-node-context-collapse-more-than 5
  "How many backlinks before they should all start collapsed."
  :type '(choice natnum (const :value nil))
  :package-version '(org-node . "2.0.0"))

;; (defcustom org-node-context-truncate-to-lines 18
;;   "Experimental.
;; Applies when the hook `org-node-context-postprocess-hook'
;; contains `org-node-context--truncate-buffer'."
;;   :type '(choice natnum (const :value nil))
;;   :package-version '(org-node . "2.0.0"))

;; TODO: Solve problem if truncating away a :END: or #+END_... but not #+BEGIN,
;; or vice versa.
;; (defun org-node-context--truncate-buffer ()
;;   (when-let ((cutoff org-node-context-truncate-to-lines))
;;     (when (> (line-number-at-pos) cutoff)
;;       (forward-line (- cutoff))
;;       (delete-region (point-min) (point)))
;;     (when (> (line-number-at-pos (point-max)) cutoff)
;;       (goto-char (point-min))
;;       (forward-line cutoff)
;;       (delete-region (point) (point-max)))))

(defun org-node-context--strip-meta-data ()
  "Delete any heading and properties/logbook drawers."
  (save-excursion
    (delete-region (point-min) (org-node-full-end-of-meta-data))))

(defun org-node-context--strip-backlinks ()
  "Delete any backlinks drawer."
  (org-node--delete-drawer "BACKLINKS"))

(defun org-node-context--strip-comments ()
  "Delete any Org comments."
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (if (org-at-comment-p)
          (delete-line)
        (forward-line)))))

(defun org-node-context--expand-or-collapse ()
  "Expand or collapse sections depending on count of sections."
  ;;  Don't collapse if user has been browsing the buffer
  (unless (bobp)
    (if (> (org-node-context--count-sections)
           org-node-context-collapse-more-than)
        (magit-section-show-level-2-all)
      (magit-section-show-level-3-all))))

(defun org-node-context--count-sections ()
  "Return the number of Magit sections in current buffer."
  (let ((n-sections 0))
    (magit-map-sections (lambda (_) (cl-incf n-sections)))
    n-sections))

;; TODO
(defun org-node-context--restore-context-state ()
  "Should run near the end of `org-node-context-refresh-hook'."
  (when-let* ((id org-node-context--current)
              (state (gethash id org-node-context--remembered-state)))
    (seq-let ( num-sections pt win-pt ) state
      (when (= num-sections (org-node-context--count-sections))
        ;; FIXME: first restore collapse states
        (goto-char pt)
        (cl-assert (eq (selected-window) (get-buffer-window)))
        (set-window-point (selected-window) win-pt)))))

(defcustom org-node-context-postprocess-hook
  (list #'org-node-context--strip-meta-data
        #'org-node-context--strip-backlinks
        #'org-node-context--strip-comments
        ;; #'org-node-context--truncate-buffer
        )
  "Hook run in a temp buffer containing a backlink preview snippet.
This can be used to transform the snippet into a desired appearance.

Point is inside the link for which the preview is being generated.

Font-locking is NOT in effect at this time, so there are no text
properties.  Org-mode is enabled, but the org-element cache is not."
  :type 'hook
  :package-version '(org-node . "2.0.0"))

(defcustom org-node-context-refresh-hook
  (list #'org-node-context--expand-or-collapse
        ;; #'org-node-context--restore-context-state
        )
  "Hook run in a context buffer after refreshing it."
  :type 'hook
  :package-version '(org-node . "2.0.0"))

(defcustom org-node-context-main-buffer "*org-node context*"
  "Name of the main context buffer."
  :type 'string
  :package-version '(org-node . "3.13.0"))

;;;###autoload
(define-minor-mode org-node-context-follow-local-mode
  "Update the context buffer when point moves in an Org buffer.

-----"
  :require 'org-node
  (cond
   ((not org-node-context-follow-local-mode)
    (remove-hook 'post-command-hook #'org-node-context--try-refresh t))
   ((not (derived-mode-p 'org-mode))
    (org-node-context-follow-local-mode 0))
   (t
    (add-hook 'post-command-hook #'org-node-context--try-refresh nil t))))

;;;###autoload
(define-globalized-minor-mode org-node-context-follow-mode
  org-node-context-follow-local-mode
  org-node-context-follow-local-mode)

(defun org-node-context-visit-thing ()
  "Visit the thing under point."
  (interactive () org-node-context-mode)
  (unless (derived-mode-p 'org-node-context-mode)
    (error "`org-node-context-visit-thing' called outside context buffer"))
  ;; Bit magical, but `magit-insert-section' can store a
  ;; link as the "value" at that section.
  (let* ((value-atpt (oref (magit-current-section) value))
         link-pos
         (origin (pcase value-atpt
                   ((pred org-mem-entry-p) nil)
                   ((pred org-mem-link-p)
                    (setq link-pos (org-mem-link-pos value-atpt))
                    (org-node-context--get-link-origin value-atpt))
                   ((pred listp) nil))))
    (if origin
        (progn
          (org-node-goto origin)
          (goto-char link-pos)
          (recenter))
      (message "Point not on a backlink snippet"))))

(defun org-node-context-raise-1 ()
  "Either display a context buffer or refresh an already visible one."
  (interactive)
  (let ((buf org-node-context-main-buffer))
    (cond
     ((derived-mode-p 'org-node-context-mode)
      (save-excursion
        (org-node-context--refresh)))

     ((get-buffer-window buf 'visible)
      (if (derived-mode-p 'org-mode)
          (org-node-context--ensure-context-is-for-here)
        (org-node-context--refresh buf)))

     ((get-buffer buf)
      (let ((display-buffer-overriding-action
             '(( display-buffer-in-previous-window
                 display-buffer-pop-up-window )
               (inhibit-same-window . t))))
        (display-buffer buf)))

     ((derived-mode-p 'org-mode)
      (org-node-context--refresh (get-buffer-create buf)
                                 (org-entry-get-with-inheritance "ID"))
      (display-buffer buf))

     (t
      (message "Found no context buffer, visit an org-mode buffer first")))))

;;;###autoload
(defun org-node-context-raise ()
  "Either display a context buffer or refresh an already visible one.

To reiterate: if it was not visible, only bring it up for
display, do NOT also refresh it.  Leave that for the second time
the user invokes the command.

This can be handy when not using `org-node-context-follow-mode',
offering the possibility to keep the context buffer focused on some
other note than the one at point.

Repeatable on the last key of a key sequence if
`repeat-on-final-keystroke' is t."
  (interactive)
  (setq last-repeatable-command #'org-node-context-raise-1)
  (if repeat-on-final-keystroke
      (repeat nil)
    (org-node-context-raise-1)))

;;;###autoload
(defun org-node-context-toggle ()
  "Show the main context buffer, or hide it if already showing."
  (interactive)
  (if-let ((win (get-buffer-window org-node-context-main-buffer 'visible)))
      (quit-window nil win)
    (let ((buf (get-buffer-create org-node-context-main-buffer)))
      (when (derived-mode-p 'org-mode)
        (org-node-context--refresh buf (org-entry-get-with-inheritance "ID")))
      (display-buffer buf))))

;;;###autoload
(defun org-node-context-dwim ()
  "Call `org-node-context-toggle' or `org-node-context-raise'.
Call the former if `org-node-context-follow-mode' is enabled,
otherwise call the latter."
  (interactive)
  (org-node-context--clean-stale-previews)
  (if org-node-context-follow-mode
      (org-node-context-toggle)
    (org-node-context-raise)))

;; TODO: Use any buffer that may be rendering the correct context
(defun org-node-context--try-refresh ()
  "For `post-command-hook' in an Org-mode buffer."
  (when (get-buffer-window org-node-context-main-buffer 'visible)
    (org-node-context--ensure-context-is-for-here)))

(defun org-node-context--ensure-context-is-for-here ()
  (let ((id (org-entry-get-with-inheritance "ID")))
    (and id
         (not (org-node-context--displaying-p nil id))
         (org-node-context--refresh org-node-context-main-buffer id))))

(defun org-node-context--displaying-p (buf id)
  "Is BUF displaying context for ID?"
  (when-let ((buf (get-buffer (or buf org-node-context-main-buffer))))
    (equal id (buffer-local-value 'org-node-context--current buf))))

(defun org-node-context-refresh-this-buffer (&rest _)
  "Designed for `revert-buffer-function'."
  (interactive () org-node-context-mode)
  (cl-assert (derived-mode-p 'org-node-context-mode))
  (org-node-context--refresh (current-buffer)))


;;; Plumbing

(defvar org-node-context--previews (make-hash-table :test 'equal)
  "Table of preview snippets of backlink contexts.

Each table value is an alist of \((POS-DIFF . TEXT) ...) where POS-DIFF
corresponds to a link\\='s buffer position relative to that of its
heading, and TEXT is an output of `org-node-context--get-preview'.")

(defun org-node-context--refresh (&optional buf id from-history-nav)
  "Refresh buffer BUF to show context for node known by ID.

If argument BUF not supplied, use `org-node-context-main-buffer'.
If argument ID not supplied, just refresh the context already shown in
that buffer."
  (org-node-context--maybe-init-persistence)
  (with-current-buffer (get-buffer-create (or buf org-node-context-main-buffer))
    (unless (derived-mode-p 'org-node-context-mode)
      (org-node-context-mode))
    (let ((inhibit-read-only t))
      (when (and org-node-context--current (null id))
        (setq id org-node-context--current))
      (when (and id (get-buffer-window))
        (puthash id
                 (list (point)
                       (window-point)
                       (org-node-context--count-sections))
                 org-node-context--remembered-state)
        (and org-node-context--current
             (not from-history-nav)
             (push org-node-context--current org-node-context--past)))
      (setq org-node-context--current id)
      (let ((node (org-mem-entry-by-id id)))
        (unless node
          (error "org-node-context: ID not known: %s" id))
        (erase-buffer)
        (setq header-line-format
              (concat "Context for \"" (org-mem-entry-title node) "\""))
        (magit-insert-section (org-node-context :root)
          (when-let ((links (org-mem-id-links-to-entry node)))
            (magit-insert-section (org-node-context :id-links)
              (magit-insert-heading "ID backlinks:")
              (org-node-context--insert-backlink-sections links)
              (insert "\n")))
          (when-let ((links (org-mem-roam-reflinks-to-entry node)))
            (magit-insert-section (org-node-context :reflinks)
              (magit-insert-heading "Ref backlinks:")
              (org-node-context--insert-backlink-sections links)
              (insert "\n"))))
        (org-node--kill-work-buffers)
        (run-hooks 'org-node-context-refresh-hook)))))

(defun org-node-context--insert-backlink-sections (links)
  "Insert a section displaying a preview of LINK."
  (dolist (link (sort links #'org-node-context--origin-title-lessp))
    (let* ((entry (org-node-context--get-link-origin link))
           (breadcrumbs (if-let ((olp (org-mem-olpath-with-file-title entry)))
                            (string-join olp " > ")
                          "Top")))
      (magit-insert-section (org-node-context link)
        (magit-insert-heading
          (format "%s (%s)"
                  (propertize (org-mem-title entry)
                              'face
                              'org-node-context-origin-title)
                  (propertize breadcrumbs 'face 'org-node-parent)))
        (insert (org-node-context--get-preview link))
        (insert "\n")))))

(defun org-node-context--get-preview (link)
  "Get a preview snippet from around LINK in its containing file.

Actually, if a snippet was previously cached, return the cached version,
else briefly visit the file, go to the link and call
`org-node-context--extract-entry-at-point'."
  (let* ((entry (org-node-context--get-link-origin link))
         (key (or (org-mem-entry-id entry) (org-mem-entry-pseudo-id entry)))
         (link-pos (org-mem-link-pos link))
         ;; Tracking `pos-diff' lets us avoid wiping all cached previews
         ;; in a large file every time it is saved -- doing so would make the
         ;; cache useless, when you are working in a large file with links
         ;; between parts of itself.
         (pos-diff (- link-pos (org-mem-entry-pos entry))))
    (with-memoization (alist-get pos-diff (gethash key org-node-context--previews))
      (let (snippet)
        (with-current-buffer (org-node--work-buffer-for (org-mem-file entry))
          (goto-char link-pos)
          (setq snippet (org-node-context--extract-entry-at-point)))
        (with-current-buffer (org-mem-scratch)
          (erase-buffer)
          (insert snippet)
          (goto-char pos-diff)
          (run-hooks 'org-node-context-postprocess-hook)
          ;; Finally font-lock now that we are in a tiny buffer that
          ;; contains only the snippet that needs to be font-locked, not the
          ;; entire source file.
          (font-lock-ensure)
          (buffer-string))))))

(defun org-node-context--extract-entry-at-point ()
  "Return whole entry at point as a string, including heading if any."
  (save-excursion
    (string-trim (buffer-substring-no-properties
                  (org-back-to-heading-or-point-min)
                  (or (outline-next-heading) (point-max))))))

(defun org-node-context--origin-title-lessp (link-1 link-2)
  "Return t if LINK-1 should be sorted before LINK-2.

Decide this by getting the titles of the nodes wherein the links were
found, and checking if the first title would come lexicographically
before the second title."
  (string<
   (org-mem-entry-title (org-node-context--get-link-origin link-1))
   (org-mem-entry-title (org-node-context--get-link-origin link-2))))

(defun org-node-context--get-link-origin (link)
  "Return the entry that contains LINK.
Actually return the ancestor ID-node, if there is one and the direct
entry has no ID."
  (let ((id (org-mem-link-nearby-id link)))
    (or (and id (org-mem-entry-by-id id))
        (org-mem-link-entry link))))


;;; Persistence

(defcustom org-node-context-persist-on-disk nil
  "Whether to sync cached backlink previews to disk.
The disk location is `org-node-data-dir'.

Here\\='s how you test whether this is noticeable on your system:
1. Restart Emacs
2. Open a file with many subtree nodes
3. Collapse them all (i.e. S-TAB until you see only the headings)
4. Have a context buffer open with `org-node-context-follow-mode'
5. Hold the \\[next-line] key."
  :type 'boolean
  :package-version '(org-node . "2.0.0"))

(defvar org-node-context--persist-timer (timer-create))

(defun org-node-context--maybe-init-persistence (&rest _)
  "Try to restore `org-node-context--previews' from disk.
Then start occasionally syncing back to disk.
No-op if user option `org-node-context-persist-on-disk' is nil."
  (when (and org-node-context-persist-on-disk
             (hash-table-empty-p org-node-context--previews))
    (cancel-timer org-node-context--persist-timer)
    (setq org-node-context--persist-timer
          (run-with-idle-timer 30 t #'org-node-context--persist))
    (org-node-context--persist)))

(defun org-node-context--persistence-file ()
  "Return path to file that caches previews between sessions."
  (mkdir org-node-data-dir t)
  (expand-file-name "org-node-backlink-previews.eld" org-node-data-dir))

(defun org-node-context--persist ()
  "Sync all cached previews with those on disk."
  (org-node-context--clean-stale-previews)
  (when (file-readable-p (org-node-context--persistence-file))
    (with-temp-file (org-node-context--persistence-file)
      (insert-file-contents (org-node-context--persistence-file))
      (let ((data (read (current-buffer))))
        (when (hash-table-p data)
          (setq org-node-context--previews
                (map-merge 'hash-table data org-node-context--previews))
          (org-node-context--clean-stale-previews)))
      (erase-buffer)
      (let ((print-length nil))
        (prin1 org-node-context--previews (current-buffer)))))
  nil)

(provide 'org-node-context)

;;; org-node-context.el ends here

;; Local Variables:
;; checkdoc-spellcheck-documentation-flag: nil
;; checkdoc-verb-check-experimental-flag: nil
;; emacs-lisp-docstring-fill-column: 72
;; read-symbol-shorthands: (("and$"      . "cond-let--and$")
;;                          ("and>"      . "cond-let--and>")
;;                          ("and-let"   . "cond-let--and-let")
;;                          ("if-let"    . "cond-let--if-let")
;;                          ("when$"     . "cond-let--when$")
;;                          ("when-let"  . "cond-let--when-let")
;;                          ("while-let" . "cond-let--while-let"))
;; End: