Add org-roam-consult

lisp/org-roam-consult.el

@@ -0,0 +1,163 @@
+;;; org-roam-consult.el --- Search org-roam nodes with consult  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2022  Chris Barrett
+
+;; Author: Chris Barrett <chris@walrus.cool>
+
+;; 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 of the License, 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package exposes a command, `org-roam-consult', which is a version
+;; of`consult-ripgrep' that shows the titles of org files rather than their
+;; filepath. This is desirable when searching org-roam files, since filenames
+;; may not correspond to a note's title.
+
+;; Example configuration:
+;;
+;;     (use-package org-roam-consult
+;;       :commands (org-roam-consult))
+
+;;; Code:
+
+(require 'consult)
+(require 'org)
+(require 'org-roam)
+(require 'memoize)
+(require 'pcre2el)
+
+(defgroup org-roam-consult nil
+  "Search org-roam nodes with consult."
+  :group 'productivity
+  :prefix "org-roam-consult-")
+
+
+(defface org-roam-consult-highlight
+  `((t (:inherit highlight)))
+  "Face for hits for a search term."
+  :group 'org-roam-consult)
+
+(defvar org-roam-consult-title-search-byte-limit 1024
+  "The max number of bytes to look at when trying to find a roam node's title.")
+
+
+
+(defun org-roam-consult--replace-links-in-string (str)
+  (save-match-data
+    (with-temp-buffer
+      (insert str)
+      (goto-char (point-min))
+
+      ;; Replace links with their descriptions.
+      (save-excursion
+        (while (search-forward-regexp org-link-bracket-re nil t)
+          (replace-match (match-string 2))))
+
+      ;; Best-effort processing for remaining line-wrapped links
+      (save-excursion
+        (while (search-forward-regexp (rx "[[" (+? nonl) "][" (group (+? nonl)) (? "]")) nil t)
+          (replace-match (match-string 1))))
+
+      (buffer-substring (point-min) (point-max)))))
+
+(defun org-roam-consult--candidate-group (cand transform)
+  "Return title for CAND or TRANSFORM the candidate."
+  (let* ((line (substring cand (1+ (length (get-text-property 0 'consult--grep-file cand)))))
+         (filename (get-text-property 0 'consult--grep-file cand)))
+    (if transform
+        (org-roam-consult--replace-links-in-string line)
+      (org-roam-consult--format-group-title filename))))
+
+(defun org-roam-consult--lookup-title (file)
+  (with-temp-buffer
+    (insert-file-contents (expand-file-name file org-roam-directory) nil nil org-roam-consult-title-search-byte-limit)
+    (goto-char (point-min))
+    (if (search-forward-regexp (rx bol "#+title:" (* space) (group (+ any)) eol))
+        (match-string 1)
+      file)))
+
+(defun org-roam-consult--format-group-title (file)
+  (let ((title (org-roam-consult--lookup-title file))
+        (dir (-some->> (file-name-directory file) (string-remove-prefix "/") (string-remove-suffix "/"))))
+    (if (or (null dir) (string-blank-p dir))
+        title
+      (format "%s > %s" dir title))))
+
+(ignore-errors
+  (memoize 'org-roam-consult--format-group-title 60))
+
+;; HACK: brutal copy-pasta to tweak two expressions in `consult--grep-format' to
+;; make outputs more readable.
+(defun org-roam-consult--format-results (async builder)
+  "Return ASYNC function highlighting grep match results.
+BUILDER is the command argument builder."
+  (let ((highlight))
+    (lambda (action)
+      (cond
+       ((stringp action)
+        (setq highlight (plist-get (funcall builder action) :highlight))
+        (funcall async action))
+       ((consp action)
+        (let (result)
+          (save-match-data
+            (dolist (str action)
+              (when (and (string-match consult--grep-match-regexp str)
+                         ;; Filter out empty context lines
+                         (or (/= (aref str (match-beginning 3)) ?-)
+                             (/= (match-end 0) (length str))))
+                (let* ((file (match-string 1 str))
+                       (line (format "%4s" (match-string 2 str)))
+                       (ctx (= (aref str (match-beginning 3)) ?-))
+                       (sep (if ctx "-" " "))
+                       (content (substring str (match-end 0)))
+                       (file-len (length file))
+                       (line-len (length line)))
+                  (when (> (length content) consult-grep-max-columns)
+                    (setq content (substring content 0 consult-grep-max-columns)))
+                  (when highlight
+                    (funcall highlight content))
+                  (setq str (concat file sep line sep content))
+                  ;; Store file name in order to avoid allocations in `consult--grep-group'
+                  (add-text-properties 0 file-len `(face consult-file consult--grep-file ,file) str)
+                  (put-text-property (1+ file-len) (+ 1 file-len line-len) 'face 'consult-line-number str)
+                  (when ctx
+                    (add-face-text-property (+ 2 file-len line-len) (length str) 'consult-grep-context 'append str))
+                  (push str result)))))
+          (funcall async (nreverse result))))
+       (t (funcall async action))))))
+
+;;;###autoload
+(defun org-roam-consult (&optional initial)
+  "Search for regexp with rg in `org-roam-directory' with INITIAL input."
+  (interactive)
+  (let* ((default-directory org-roam-directory)
+         (read-process-output-max (max read-process-output-max (* 1024 1024))))
+    (consult--read
+     (consult--async-command #'consult--ripgrep-builder
+       (org-roam-consult--format-results #'consult--ripgrep-builder)
+       :file-handler t)
+     :prompt "Search Roam: "
+     :lookup #'consult--lookup-member
+     :state (consult--grep-state)
+     :initial (consult--async-split-initial initial)
+     :add-history (consult--async-split-thingatpt 'symbol)
+     :require-match t
+     :category 'consult-grep
+     :group #'org-roam-consult--candidate-group
+     :history '(:input consult--grep-history)
+     :sort nil)))
+
+(provide 'org-roam-consult)
+
+;;; org-roam-consult.el ends here