Link types for Org Roam

org-roam-relationship.el

;;; org-roam-relationship.el --- Link types to represent relationships in Org Roam  -*- lexical-binding: t; -*-
;;
;; 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, 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;;; Code:
(require 'cl-lib)

(defgroup org-roam-relationship nil
  "Custom link types specifying relationships for Org Roam."
  :group 'org-roam
  :prefix "org-roam-relationship-")

(defun org-roam-relationship-set-types (symbol tuples)
  "Set SYMBOL to the value of TUPLES, after updating Org Mode's link
types using `org-link-set-parameters'."
  (dolist (tuple tuples)
    (seq-let (link-type _) tuple
      (org-link-set-parameters link-type :follow #'org-roam-id-open)))
  (set-default-toplevel-value symbol tuples))

(defcustom org-roam-relationship-types '(("derived_from" "Derived from")
                                         ("derivative_of" "Derivative of"))
  "Custom relationship types available for use."
  :type '(repeat
          (list (string :tag "Org Mode link type")
                (string :tag "Relationship name")))
  :set #'org-roam-relationship-set-types
  :group 'org-roam-relationship)

(defcustom org-roam-relationship-only-show-unique-backlinks t
  "When this option is t, default to only showing unique
relationship backlinks in the Org Roam backlinks buffer."
  :type 'boolean
  :group 'org-roam-relationship)

(defun org-roam-relationship-get-type-name (type)
  (cadr (assoc type org-roam-relationship-types #'string=)))

(defun org-roam-relationship-post-insert-prompt (id description)
  "Prompt for a relationship, and update the link at point to match
the user's selection."
  (let ((link-type (completing-read "Relationship type: "
                                    (append
                                     (list "default")
                                     (mapcar #'cadr org-roam-relationship-types)
                                     (mapcar #'cadddr org-roam-relationship-types)))))
    (unless (string= link-type "default")
      (when (org-in-regexp org-link-bracket-re 1)
        ;; If we're at a link, then we're going to replace it
        (save-excursion
          (goto-char (match-beginning 1))
          (delete-char 2) ;; delete "id"
          (insert
           (cl-loop for (r-type r-text) in org-roam-relationship-types
                    if (string= r-text link-type)
                    return r-type)))))))

(define-minor-mode org-roam-relationship-mode
  "Add features to make Org Roam's backlinks able to store a relationship.

This adds a hook to prompt the user after inserting an Org Roam
node (via `org-roam-node-insert') to also provide a relationship.
Relationships are defined in `org-roam-relationship-types', which
can be customized.

This also adds a section to `org-roam-mode-sections' to display
relationship backlinks."
  :lighter ""
  :global t
  (if org-roam-relationship-mode
      (progn
        (add-hook 'org-roam-post-node-insert-hook
                  'org-roam-relationship-post-insert-prompt)
        (add-to-list 'org-roam-mode-sections
                     'org-roam-relationship-section))
    (remove-hook 'org-roam-post-node-insert-hook
                 'org-roam-relationship-post-insert-prompt)
    (setq org-roam-mode-sections (remove 'org-roam-relationship-section org-roam-mode-sections))))

(cl-defun org-roam-relationship-backlinks-get (node type &key unique)
  "Return the backlinks for NODE of type TYPE.

When UNIQUE is nil, show all positions where references are found.
When UNIQUE is t, limit to unique sources."
  (let* ((sql (if unique
                  [:select :distinct [source dest pos properties]
                   :from links
                   :where (= dest $s1)
                   :and (= type $s2)
                   :group :by source
                   :having (funcall min pos)]
                [:select [source dest pos properties]
                 :from links
                 :where (= dest $s1)
                 :and (= type $s2)]))
         (backlinks (org-roam-db-query sql (org-roam-node-id node) type)))
    (cl-loop for backlink in backlinks
             collect (pcase-let ((`(,source-id ,dest-id ,pos ,properties) backlink))
                       (org-roam-populate
                        (org-roam-backlink-create
                         :source-node (org-roam-node-create :id source-id)
                         :target-node (org-roam-node-create :id dest-id)
                         :point pos
                         :properties properties))))))

(cl-defun org-roam-relationship-section (node &key (unique org-roam-relationship-only-show-unique-backlinks))
  "Render a section showing specific relationship backlinks, broken
out into sections."
  (dolist (tuple org-roam-relationship-types)
    (seq-let (type text) tuple
      (when-let (backlinks (seq-sort #'org-roam-backlinks-sort
                                     (org-roam-relationship-backlinks-get node type :unique unique)))
        (magit-insert-section (org-roam-relationship-backlinks)
          (magit-insert-heading (concat text ":"))
          (dolist (backlink backlinks)
            (org-roam-node-insert-section
             :source-node (org-roam-backlink-source-node backlink)
             :point (org-roam-backlink-point backlink)
             :properties (org-roam-backlink-properties backlink)))
          (insert "\n"))))))

(provide 'org-roam-relationship)