awesome-emacs/org-roam
1
0
Fork 0
mirror of https://github.com/org-roam/org-roam synced 2025-08-01 12:17:21 -05:00
Code Issues Packages Projects Releases Wiki Activity

(feat): move fuzzy links to roam: links (#1105)

Browse Source
This commit is contained in:
Jethro Kuan
2020-09-23 17:58:18 +08:00
committed by GitHub
parent da6af3a468
commit ae32c465de
8 changed files with 539 additions and 384 deletions
Download Patch File Download Diff File Expand all files Collapse all files

274
org-roam-link.el Normal file
View File

@ -0,0 +1,274 @@
;;; 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