org-roam/org-roam-link.el

;;; org-roam-link.el --- Custom links for Org-roam -*- coding: utf-8; lexical-binding: t; -*-

;; Copyright © 2020 Jethro Kuan <jethrokuan95@gmail.com>
;;                  Alan Carroll

;; Author: Jethro Kuan <jethrokuan95@gmail.com>
;; URL: https://github.com/org-roam/org-roam
;; Keywords: org-mode, roam, convenience
;; Version: 1.2.1
;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (s "1.12.0") (org "9.3") (emacsql "3.0.0") (emacsql-sqlite3 "1.0.2"))

;; 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, 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.

;;; Commentary:
;;
;; This adds the custom `roam:' link to Org-roam. `roam:' links allow linking to
;; Org-roam files via their titles and headlines.
;;
;;; Code:
;;;; Dependencies

(require 'ol)
(require 'org-roam-compat)

(defvar org-roam-completion-ignore-case)
(declare-function  org-roam--find-file                  "org-roam")
(declare-function  org-roam-find-file                   "org-roam")


(defcustom org-roam-link-auto-replace t
  "When non-nil, replace Org-roam's roam links with file or id links whenever possible."
  :group 'org-roam
  :type 'boolean)

;;; the roam: link
(org-link-set-parameters "roam"
                         :follow #'org-roam-link-follow-link)

(defun org-roam-link-follow-link (path)
  "Navigates to location specified by PATH."
  (pcase-let ((`(,link-type ,loc ,desc ,mkr) (org-roam-link--get-location path)))
    (when (and org-roam-link-auto-replace loc desc)
      (org-roam-link--replace-link link-type loc desc))
    (pcase link-type
          ("file"
           (if loc
               (org-roam--find-file loc)
             (org-roam-find-file desc nil nil t)))
          ("id"
           (org-goto-marker-or-bmk mkr)))))

;;; Retrieval Functions
(defun org-roam-link--get-titles ()
  "Return all titles within Org-roam."
  (mapcar #'car (org-roam-db-query [:select [titles:title] :from titles])))

(defun org-roam-link--get-headlines (&optional file with-marker use-stack)
  "Return all outline headings for the current buffer.
If FILE, return outline headings for passed FILE instead.
If WITH-MARKER, return a cons cell of (headline . marker).
If USE-STACK, include the parent paths as well."
  (let* ((buf (or (and file
                       (or (find-buffer-visiting file)
                           (find-file-noselect file)))
                  (current-buffer)))
         (outline-level-fn outline-level)
         (path-separator "/")
         (stack-level 0)
         stack cands name level marker)
    (with-current-buffer buf
      (save-excursion
        (goto-char (point-min))
        (while (re-search-forward org-complex-heading-regexp nil t)
          (save-excursion
            (setq name (substring-no-properties (or (match-string 4) "")))
            (setq marker (point-marker))
            (when use-stack
              (goto-char (match-beginning 0))
              (setq level (funcall outline-level-fn))
              ;; Update stack.  The empty entry guards against incorrect
              ;; headline hierarchies, e.g. a level 3 headline
              ;; immediately following a level 1 entry.
              (while (<= level stack-level)
                (pop stack)
                (cl-decf stack-level))
              (while (> level stack-level)
                (push name stack)
                (cl-incf stack-level))
              (setq name (mapconcat #'identity
                                    (reverse stack)
                                    path-separator)))
            (push (if with-marker
                      (cons name marker)
                    name) cands)))))
    (nreverse cands)))

(defun org-roam-link--get-file-from-title (title &optional no-interactive)
  "Return the file path corresponding to TITLE.
When NO-INTERACTIVE, return nil if there are multiple options."
  (let ((files (mapcar #'car (org-roam-db-query [:select [titles:file] :from titles
                                                 :where (= titles:title $v1)]
                                                (vector title)))))
    (pcase files
      ('nil nil)
      (`(,file) file)
      (_
       (unless no-interactive
         (completing-read "Select file: " files))))))

(defun org-roam-link--get-id-from-headline (headline &optional file)
  "Return (marker . id) correspondng to HEADLINE.
If FILE, get headline from FILE instead.
If there is no corresponding headline, return nil."
  (save-excursion
    (with-current-buffer (or (and file
                                  (or (find-buffer-visiting file)
                                      (find-file-noselect file)))
                             (current-buffer))
      (let ((headlines (org-roam-link--get-headlines file 'with-markers)))
        (when-let ((marker (cdr (assoc-string headline headlines))))
          (goto-char marker)
          (cons marker
                (when org-roam-link-auto-replace
                  (org-id-get-create))))))))

;;; Path-related functions
(defun org-roam-link--split-path (path)
  "Splits PATH into title and headline.
Return a list of the form (type title has-headline-p headline star-idx).
type is one of `title', `headline', `title+headline'.
title is the title component of the path.
headline is the headline component of the path.
star-idx is the index of the asterisk, if any."
  (save-match-data
    (let* ((star-index (string-match-p "\\*" path))
           (title (substring-no-properties path 0 star-index))
           (headline (if star-index
                         (substring-no-properties path (+ 1 star-index))
                       ""))
           (type (cond ((not star-index)
                        'title)
                       ((= 0 star-index)
                        'headline)
                       (t 'title+headline))))
      (list type title headline star-index))))

(defun org-roam-link--get-location (link)
  "Return the location of Org-roam fuzzy LINK.
The location is returned as a list containing (link-type loc desc marker).
nil is returned if there is no matching location.

link-type is either \"file\" or \"id\".
loc is the target location: e.g. a file path, or an id.
marker is a marker to the headline, if applicable."
  (let (mkr link-type desc loc)
    (pcase-let ((`(,type ,title ,headline _) (org-roam-link--split-path link)))
      (pcase type
        ('title+headline
         (let ((file (org-roam-link--get-file-from-title title)))
           (if (not file)
               (org-roam-message "Cannot find matching file")
             (setq mkr (org-roam-link--get-id-from-headline headline file))
             (pcase mkr
               (`(,marker . ,target-id)
                (setq mkr marker
                      loc target-id
                      link-type "id"
                      desc headline))
               (_ (org-roam-message "cannot find matching id"))))))
        ('title
         (setq loc (org-roam-link--get-file-from-title title)
               desc title
               link-type "file")
         (when loc (setq loc (file-relative-name loc))))
        ('headline
         (setq mkr (org-roam-link--get-id-from-headline headline))
         (pcase mkr
           (`(,marker . ,target-id)
            (setq mkr marker
                  loc target-id
                  desc headline
                  link-type "id"))
           (_ (org-roam-message "Cannot find matching headline")))))
      (list link-type loc desc mkr))))

;;; Conversion Functions
(defun org-roam-link--replace-link (link-type loc &optional desc)
  "Replace link at point with a vanilla Org link.
LINK-TYPE is the Org link type, typically \"file\" or \"id\".
LOC is path for the Org link.
DESC is the link description."
  (save-excursion
    (save-match-data
      (unless (org-in-regexp org-link-bracket-re 1)
        (user-error "No link at point"))
      (replace-match "")
      (insert (org-roam-link-make-string (concat link-type ":" loc) desc)))))

(defun org-roam-link-replace-all ()
  "Replace all roam links in the current buffer."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward org-link-bracket-re nil t)
      (let ((context (org-element-context)))
          (pcase (org-element-lineage context '(link) t)
            (`nil nil)
            (link
             (when (string-equal "roam" (org-element-property :type link))
               (pcase-let ((`(,link-type ,loc ,desc _) (org-roam-link--get-location (org-element-property :path link))))
                 (when (and link-type loc)
                   (org-roam-link--replace-link link-type loc desc))))))))))

(defun org-roam-link--replace-link-on-save ()
  "Hook to replace all roam links on save."
  (when org-roam-link-auto-replace
    (org-roam-link-replace-all)))

;;; Completion
(defun org-roam-link-complete-at-point ()
  "Do appropriate completion for the link at point."
  (let ((end (point))
        (start (point))
        (exit-fn (lambda (&rest _) nil))
        collection)
    (when (org-in-regexp org-link-bracket-re 1)
      (setq start (+ (match-beginning 1) (length "roam:"))
            end (match-end 1))
      (let ((context (org-element-context)))
        (pcase (org-element-lineage context '(link) t)
          (`nil nil)
          (link (when (string-equal "roam" (org-element-property :type link))
                  (pcase-let ((`(,type ,title _ ,star-idx)
                               (org-roam-link--split-path (org-element-property :path link))))
                    (pcase type
                      ('title+headline
                       (when-let ((file (org-roam-link--get-file-from-title title t)))
                         (setq collection (apply-partially #'org-roam-link--get-headlines file))
                         (setq start (+ start star-idx 1))))
                      ('title
                       (setq collection #'org-roam-link--get-titles))
                      ('headline
                       (setq collection #'org-roam-link--get-headlines)
                       (setq start (+ start star-idx 1))))))))))
    (when collection
      (let ((prefix (buffer-substring-no-properties start end)))
        (list start end
              (if (functionp collection)
                  (completion-table-case-fold
                   (completion-table-dynamic
                    (lambda (_)
                      (cl-remove-if (apply-partially #'string= prefix)
                                    (funcall collection))))
                   (not org-roam-completion-ignore-case))
                collection)
              :exit-function exit-fn)))))

(provide 'org-roam-link)
;;; org-roam-link.el ends here