Skip to content

Instantly share code, notes, and snippets.

@zot

zot/org-roam-ivy.el

Last active October 3, 2023 20:20
Show Gist options
  • Star 2 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save zot/1d6f164178f41498f912613f2054bbb7 to your computer and use it in GitHub Desktop.
Save zot/1d6f164178f41498f912613f2054bbb7 to your computer and use it in GitHub Desktop.
Download ZIP
first cut at scalable incremental completion for org-roam
Raw
org-roam-ivy.el
;;; org-roam-ivy.el --- scalable incremental completion for org-roam -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright © 2021 Bill Burdick <bill.burdick@gmail.com>
;; Author: Bill Burdick <bill.burdick@gmail.com>
;; URL: https://gist.github.com/zot/1d6f164178f41498f912613f2054bbb7
;; Keywords: org-mode, roam, convenience
;; Version: 0.0.15
;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (org "9.4") (emacsql "3.0.0") (emacsql-sqlite "1.0.0") (magit-section "2.90.1") (org-roam "2.0.0"))
;; 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 IS ALPHA CODE. EXPECT BUGS.
;;
;; This file adds scalable full-text search to org-roam by adding an
;; index to the SQLite database and cursoring during ivy interaction.
;;
;; IMPORTANT:
;; When you start using this, make sure to run
;; (org-roam-fts-init)
;; to add the full-text index to the database.
;; add (org-roam-ivy-advise) to your startup to activate org-roam-ivy
;;
;; ANOTHER IMPORTANT NOTE:
;; If you want search to match on internal substrings rather than just prefixes
;; you need trigram support in SQLite. The current versions of emacsql-sqlite is
;; not current enough with the SQLite version but I have a pull request waiting
;; for approval on that. In the mean time, you can use my fork of emacsql for that
;; here: https://github.com/zot/emacsql
;;
;;; CHANGES
;;
;; 0.0.8: Adding highlighting to search results, shortening names
;; 0.0.9: Adding KNOWN BUGS section
;; 0.0.10: Adding (org-roam-ivy-advise) to make org-roam use this instead of its completion
;; 0.0.11: Removing diagnostic message
;; 0.0.12: Adding support for trigram tokenizer (if present)
;; 0.0.13: Adding note about trigram support
;; 0.0.14: Fix creating new nodes
;; 0.0.15: Add order by title, alias
;; 0.0.16: Separate out declarations by "fts" and "ivy"
;; 0.0.17: Ordering seems to have fixed scrolling bug
;;
;;; KNOWN BUGS
;;; Code:
(setq lexical-binding t)
(defun &1-f (f &rest args) #'(lambda (x) (apply f (append args (list x)))))
(defmacro &1 (fun &rest args) `(&1-f #',fun ,@args))
;;; FTS CODE
(defvar org-roam-fts-trigrams nil)
(defvar org-roam-fts-indexed nil)
(defvar org-roam-fts-start 0)
(defvar org-roam-fts-len 20)
(defvar org-roam-fts-use-verbose nil)
;; convenience expressions
;; (setq org-roam-fts-use-verbose t)
;; (setq org-roam-fts-use-verbose nil)
(defvar org-roam-fts-rows nil)
(defvar org-roam-fts-result nil) ; result of ivy search
(defvar org-roam-fts-terms nil)
(defun org-roam-fts-cmds-drop ()
`([:drop-table-if-exists nodes-fts]
[:drop-trigger-if-exists nodes-insert]
[:drop-trigger-if-exists nodes-delete]
[:drop-trigger-if-exists nodes-update]))
(defun org-roam-fts-cmds-init ()
`([:create-virtual-table-if-not-exists nodes_fts :using (funcall fts5 title (= content nodes) (= content_rowid rowid) ,@(and org-roam-fts-trigrams '((= tokenize 'trigram))))]
[:create-trigger-if-not-exists nodes-insert :after-insert :on nodes :begin
:insert-into nodes-fts [rowid title] :select [new:rowid new:title]
:\;
:end]
[:create-trigger-if-not-exists nodes-delete :after-delete :on nodes :begin
:insert-into nodes-fts [nodes-fts rowid title] :select ['delete old:rowid old:title]
:\;
:end]
[:create-trigger-if-not-exists nodes-update :after-update :on nodes :begin
:insert-into nodes-fts [nodes-fts rowid title] :select ['delete old:rowid old:title]
:\;
:insert-into nodes-fts [rowid title] :select [new:rowid new:title]
:\;
:end]
[:insert-into nodes_fts [rowid title] :select [rowid title] :from nodes]))
(defun org-roam-fts-completion-sql ()
`[:with
[(as s [:select [file pos (as n:title alias) n:title id properties olp]
:from [(as nodes n) ,(if org-roam-fts-trigrams
'(as (funcall nodes_fts $r1) fts)
'(as nodes_fts fts))]
:where ,(if org-roam-fts-trigrams
'(= n:rowid fts:rowid)
'(and (match fts:title $r1) (= n:rowid fts:rowid)))])
(as al [:select [s:file pos a:alias title node_id]
:from s
:left-join aliases a
:on (= s:id a:node_id)
:where (notnull a:alias)
])]
:select * :from s
:union
:select [* nil nil]
:from al
:order-by [title alias]
:limit $s3
:offset $s2])
(defun org-roam-fts-all-sql ()
`[:with
[(as s [:select [file pos (as title alias) title id properties olp]
:from [nodes]])
(as al [:select [s:file pos a:alias title node_id]
:from s
:left-join aliases a
:on (= s:id a:node_id)
:where (notnull a:alias)
])]
:select * :from s
:union
:select [* nil nil]
:from al
:order-by [title alias]
:limit $s2
:offset $s1])
(defun org-roam-fts-schema ()
(condition-case nil
(caar (org-roam-db-query [:select (|| $r1 sql $r1) :from sqlite-schema :where (= name 'nodes_fts)] "\""))
(error nil)))
(defun org-roam-fts-using-trigrams ()
(string-match "trigram" (or (org-roam-fts-schema) "")))
(defun org-roam-fts-supports-trigrams ()
(or (org-roam-fts-using-trigrams)
(let ((trigrams nil))
(condition-case nil
(progn
(org-roam-db-query [:create-virtual-table-if-not-exists test_fts :using (funcall fts5 test (= tokenize 'trigram))])
(org-roam-db-query [:drop-table-if-exists test_fts])
(setq trigrams t))
(error nil))
trigrams)))
(defun org-roam-fts-ensure-indexed ()
(setq org-roam-fts-trigrams (or (org-roam-fts-schema) (org-roam-fts-supports-trigrams)))
(if (or (not (org-roam-fts-schema))
(and (not (org-roam-fts-using-trigrams)) (org-roam-fts-supports-trigrams)))
(org-roam-fts-init))
(setq org-roam-fts-indexed t))
(defun org-roam-fts-verbose (fmt &rest args)
(if org-roam-fts-use-verbose
(message (apply #'format fmt args))))
(defun org-roam-fts-drop ()
"Initialize fts support for org-roam"
(org-roam-db--close)
(cl-loop for row in (org-roam-fts-cmds-drop)
do
(org-roam-db-query row)))
(defun org-roam-fts-init ()
"Initialize fts support for org-roam"
;;(org-roam-db--close)
;;(org-roam-db)
(emacsql-with-transaction (org-roam-db)
(let ((cmds (append
(org-roam-fts-cmds-drop)
(org-roam-fts-cmds-init))))
(cl-loop for row in cmds
do
(org-roam-db-query row)))))
(setq org-roam-fts-term-regex "[^ \"]\\([^ ]\\|\"\"\\)*\\( \\|$\\)\\|\"\\(\"\"\\|[^\"]\\)*\"")
(defun org-roam-fts-trim-term (str)
(cond ((string-prefix-p "\"" str) str)
((string-match "[-+*]" str) (concat "\"" str "\""))
(t (string-trim-right str))))
(defun org-roam-fts-dequote (str)
(if (eq ?\" (elt str 0))
(substring str 1 (1- (length str)))
str))
(defun org-roam-fts-compute-terms (str)
(let ((index 0)
(result nil))
(while (setq index (string-match org-roam-fts-term-regex str index))
(let* ((term (match-string 0 str))
(rterm (org-roam-fts-trim-term term)))
(if (> (length rterm) 0) (push rterm result))
(cl-incf index (length term))))
(setq org-roam-fts-terms (regexp-opt (mapcar #'org-roam-fts-dequote (reverse result))))
(mapconcat #'identity
(mapcar (if org-roam-fts-trigrams
(lambda (x) x)
(lambda (x) (concat x "*")))
(reverse result))
" ")))
(defun org-roam-fts-row-count (str)
(let ((qstr (org-roam-fts-compute-terms str)))
(caar (if (or (> (length qstr) 2) (and (not org-roam-fts-trigrams) (> (length qstr) 0)))
(org-roam-db-query
`[:with
[(as s [:select [file pos n:title n:title id properties olp]
:from [(as nodes n)
,(if org-roam-fts-trigrams
'(as (funcall nodes_fts $r1) fts)
'(as nodes_fts fts))]
:where ,(if org-roam-fts-trigrams
'(= n:rowid fts:rowid)
'(and (match fts:title $r1) (= n:rowid fts:rowid)))])
(as al [:select [s:file pos alias title node_id]
:from s
:left-join aliases a
:on (= s:id a:node_id)
:where (notnull alias)
])]
:select (funcall count *)
:from [:select * :from s
:union
:select [* nil nil]
:from al]]
qstr)
(org-roam-db-query
[:with
[(as s [:select [file pos title title id properties olp]
:from [nodes]])
(as al [:select [s:file pos alias title node_id]
:from s
:left-join aliases a
:on (= s:id a:node_id)
:where (notnull alias)
])]
:select (funcall count *)
:from [:select * :from s
:union
:select [* nil nil]
:from al]])))))
(defun org-roam-fts-rows (str &optional offset len)
(org-roam-fts-ensure-indexed)
(let* ((qstr (org-roam-fts-compute-terms str)))
(org-roam-fts-verbose "TERMS: %S" qstr)
(if (= (length qstr) 0)
(org-roam-fts-verbose "%S" (emacsql-compile (org-roam-db) (org-roam-fts-all-sql) (or offset 0) (or len 100000)))
(org-roam-fts-verbose "%S" (emacsql-compile (org-roam-db) (org-roam-fts-completion-sql) qstr (or offset 0) (or len 100000))))
(if (or (= (length qstr) 0) (and org-roam-fts-trigrams (< (length qstr) 3)))
(org-roam-db-query
(org-roam-fts-all-sql)
(or offset 0) (or len 100000))
(org-roam-db-query
(org-roam-fts-completion-sql)
qstr (or offset 0) (or len 100000)))))
(defun org-roam-fts-choose (sel)
(setq org-roam-fts-result (or (cdr (assoc sel org-roam-fts-rows))
(org-roam-node-create :title sel))))
(defun org-roam-node--format-completions (rows)
"Format rows and return an alist for node completion.
The car is the displayed title or alias for the node, and the cdr
is the `org-roam-node'."
(let ((tags-table (org-roam--tags-table)))
(cl-loop for row in rows
collect (pcase-let* ((`(,file ,pos ,alias ,title ,id ,properties ,olp) row)
(node (org-roam-node-create :id id
:file file
:title alias
:point pos
:properties properties
:olp olp
:tags (gethash id tags-table)))
(candidate-main (org-roam-node--format-entry node (1- (frame-width))))
(candidate-main (org-roam-fts-highlight-terms candidate-main))
(tag-str (org-roam--tags-to-str (org-roam-node-tags node))))
(cons (propertize (concat (propertize tag-str 'invisible t)
candidate-main)
'node node)
node)))))
(defun org-roam-fts-highlight-terms (str)
(let ((index 0)
(frags nil))
(while (setq index (string-match org-roam-fts-terms str index))
(setq frags (cons (cons index (match-end 0)) frags))
(setq index (match-end 0)))
(cl-loop for frag in frags
do
(set-text-properties (car frag) (cdr frag) '(face ivy-minibuffer-match-face-2) str)))
str)
;; alternate version of org-roam-node--completions
;; this uses the above definition of org-roam-node--format-completions
;;
;;(defun org-roam-node--completions ()
;; "Return an alist for node completion.
;;The car is the displayed title or alias for the node, and the cdr
;;is the `org-roam-node'."
;; (setq org-roam--cached-display-format nil)
;; (org-roam-node--format-completions
;; (append
;; (org-roam-db-query [:select [file pos title title id properties olp]
;; :from nodes])
;; (org-roam-db-query [:select [nodes:file pos alias title node-id]
;; :from aliases
;; :left-join nodes
;; :on (= aliases:node-id nodes:id)]))))
;;; IVY CODE
(defvar org-roam-ivy-last-query nil)
(defvar org-roam-ivy-scrolling nil)
(defun org-roam-ivy-query (str &optional pred flag)
"Query the database for STR, using PRED and FLAG (see Programmed Completion).
Return data that ivy can use.
Ivy calls this at the beginning of a search and org-roam-ivy-update will
trigger further calls to this."
;;(org-roam-fts-verbose "args: %S %S %S" str pred flag)
(let* ((index (+ ivy--index org-roam-fts-start))
(start org-roam-fts-start) ; used in diagnostic message below
(len org-roam-fts-len)
(rows (org-roam-fts-rows str org-roam-fts-start org-roam-fts-len))
(total (org-roam-fts-row-count str)))
(if (not (equal str org-roam-ivy-last-query))
(progn
(setq org-roam-ivy-last-query str)
(setq org-roam-ivy-scrolling nil)))
(org-roam-fts-verbose "search (%S) [%S %S]" flag start (+ start len))
;;determine whether to reset the index to 0
(if (and (not org-roam-ivy-scrolling) (or (not pred) (not (eq pred t))))
(progn
(setq org-roam-fts-start 0)
(setq start 0)))
(setq org-roam-ivy-scrolling t)
;;(setq org-roam-fts-rows rows)
(setq org-roam-fts-rows (org-roam-node--format-completions rows))
(setq ivy--index (- index org-roam-fts-start))
(setq ivy--full-length total)
(org-roam-node--format-completions rows)
))
(defun org-roam-ivy-inc-start (delta)
(cl-incf org-roam-fts-start delta)
(cl-incf ivy--index (- delta))
(setq ivy--old-text "^^^^MALUBA"))
(defun org-roam-ivy-update (&rest args)
(let* ((len org-roam-fts-len)
(delta (/ len 2))
(start org-roam-fts-start)
(index (+ ivy--index start))
(end (+ start len)))
(org-roam-fts-verbose "[%S %S %S]" start index end)
(if (and (> start 0) (<= (- index start) 5)) (org-roam-ivy-inc-start (- delta)))
(if (<= (- end index) 5) (org-roam-ivy-inc-start delta))))
(defun org-roam-ivy-node-read (&optional initial-input filter-fn require-match)
"Use ivy to find a node"
;;(interactive)
(setq org-roam-fts-len (* 2 ivy-height))
(setq org-roam-ivy-scrolling nil)
(setq org-roam-ivy-last-query nil)
(setq org-roam-fts-start 0)
(ivy-read "Node: " 'org-roam-ivy-query
:predicate filter-fn
:require-match require-match
:dynamic-collection t
:action 'org-roam-fts-choose
:update-fn 'org-roam-ivy-update)
org-roam-fts-result)
(defun org-roam-ivy-node-read-advice (orig &rest args)
(apply #'org-roam-ivy-node-read args))
(defun org-roam-ivy-advise ()
(advice-add 'org-roam-node-read :override 'org-roam-ivy-node-read-advice))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment