org-roam/org-roam-buffer.el

;;; org-roam-buffer.el --- Metadata buffer -*- coding: utf-8; lexical-binding: t; -*-

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

;; 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.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 library provides the org-roam-buffer functionality for org-roam
;;; Code:
;;;; Library Requires
(eval-when-compile (require 'subr-x))
(require 'cl-lib)
(require 'dash)
(require 's)

(defvar org-roam-directory)
(defvar org-link-frame-setup)
(defvar org-return-follows-link)
(defvar org-roam-backlinks-mode)
(defvar org-roam-last-window)
(defvar org-ref-cite-types) ;; in org-ref-core.el
(defvar org-roam-mode)

(declare-function org-roam-db--ensure-built   "org-roam-db")
(declare-function org-roam--extract-ref       "org-roam")
(declare-function org-roam--extract-titles    "org-roam")
(declare-function org-roam--get-title-or-slug "org-roam")
(declare-function org-roam--get-backlinks     "org-roam")
(declare-function org-roam-backlinks-mode     "org-roam")
(declare-function org-roam-mode               "org-roam")
(declare-function org-roam--find-file         "org-roam")

(defcustom org-roam-buffer-position 'right
  "Position of `org-roam' buffer.
Valid values are
 * left,
 * right,
 * top,
 * bottom."
  :type '(choice (const left)
                 (const right)
                 (const top)
                 (const bottom))
  :group 'org-roam)

(defcustom org-roam-buffer-width 0.33
  "Width of `org-roam' buffer.
Has an effect if and only if `org-roam-buffer-position' is `left' or `right'."
  :type 'number
  :group 'org-roam)

(defcustom org-roam-buffer-height 0.27
  "Height of `org-roam' buffer.
Has an effect if and only if `org-roam-buffer-position' is `top' or `bottom'."
  :type 'number
  :group 'org-roam)


(defcustom org-roam-buffer "*org-roam*"
  "Org-roam buffer name."
  :type 'string
  :group 'org-roam)

(defcustom org-roam-buffer-prepare-hook '(org-roam-buffer--insert-title
                                          org-roam-buffer--insert-backlinks
                                          org-roam-buffer--insert-ref-links)
  "Hook run in the `org-roam-buffer' before it is displayed."
  :type 'hook
  :group 'org-roam)

(defcustom org-roam-buffer-window-parameters nil
  "Additional window parameters for the `org-roam-buffer' side window.
For example: (setq org-roam-buffer-window-parameters '((no-other-window . t)))"
  :type '(alist)
  :group 'org-roam)

(defvar org-roam-buffer--current nil
  "Currently displayed file in `org-roam' buffer.")

(defun org-roam-buffer--find-file (file)
  "Open FILE in the window `org-roam' was called from."
  (if (and org-roam-last-window (window-valid-p org-roam-last-window))
      (progn (with-selected-window org-roam-last-window
               (org-roam--find-file file))
             (select-window org-roam-last-window))
    (org-roam--find-file file)))

(defun org-roam-buffer--insert-title ()
  "Insert the org-roam-buffer title."
  (insert (propertize (org-roam--get-title-or-slug
                       (buffer-file-name org-roam-buffer--current))
                       'font-lock-face
                       'org-document-title)))

(defun org-roam-buffer--pluralize (string number)
  "Conditionally pluralize STRING if NUMBER is above 1."
  (let ((l (pcase number
             ((pred (listp)) (length number))
             ((pred (integerp)) number)
             (wrong-type (signal 'wrong-type-argument
                                 `((listp integerp)
                                   ,wrong-type))))))
    (concat string (when (> l 1) "s"))))

(defun org-roam-buffer--insert-ref-links ()
  "Insert ref backlinks for the current buffer."
  (when-let ((ref (cdr (with-temp-buffer
                        (insert-buffer-substring org-roam-buffer--current)
                        (org-roam--extract-ref)))))
    (if-let* ((key-backlinks (org-roam--get-backlinks ref))
              (grouped-backlinks (--group-by (nth 0 it) key-backlinks)))
        (progn
          (insert (let ((l (length key-backlinks)))
                    (format "\n\n* %d %s\n"
                            l (org-roam-buffer--pluralize "Ref Backlink" l))))
          (dolist (group grouped-backlinks)
            (let ((file-from (car group))
                  (bls (cdr group)))
              (insert (format "** [[file:%s][%s]]\n"
                              file-from
                              (org-roam--get-title-or-slug file-from)))
              (dolist (backlink bls)
                (pcase-let ((`(,file-from _ ,props) backlink))
                  (insert (propertize (plist-get props :content)
                           'help-echo "mouse-1: visit backlinked note"
                           'file-from file-from
                           'file-from-point (plist-get props :point)))
                  (insert "\n\n"))))))
      (insert "\n\n* No ref backlinks!"))))

(defun org-roam-buffer--insert-backlinks ()
  "Insert the org-roam-buffer backlinks string for the current buffer."
  (if-let* ((file-path (buffer-file-name org-roam-buffer--current))
            (titles (with-current-buffer org-roam-buffer--current
                      (org-roam--extract-titles)))
            (backlinks (org-roam--get-backlinks (push file-path titles)))
            (grouped-backlinks (--group-by (nth 0 it) backlinks)))
      (progn
        (insert (let ((l (length backlinks)))
                     (format "\n\n* %d %s\n"
                             l (org-roam-buffer--pluralize "Backlink" l))))
        (dolist (group grouped-backlinks)
          (let ((file-from (car group))
                (bls (mapcar (lambda (row)
                                 (nth 2 row)) (cdr group))))
            (insert (format "** [[file:%s][%s]]\n"
                            file-from
                            (org-roam--get-title-or-slug file-from)))
            ;; Sort backlinks according to time of occurrence in buffer
            (setq bls (seq-sort-by (lambda (bl)
                                     (plist-get bl :point))
                                   #'<
                                   bls))
            (dolist (props bls)
              (insert "*** "
                      (if-let ((outline (plist-get props :outline)))
                          (string-join outline " > ")
                        "Top")
                      "\n"
                      (propertize
                       (s-trim (s-replace "\n" " "
                                          (plist-get props :content)))
                       'help-echo "mouse-1: visit backlinked note"
                       'file-from file-from
                       'file-from-point (plist-get props :point))
                      "\n\n")))))
    (insert "\n\n* No backlinks!")))

(defun org-roam-buffer-update ()
  "Update the `org-roam-buffer'."
  (org-roam-db--ensure-built)
  (let* ((source-org-roam-directory org-roam-directory))
    (with-current-buffer org-roam-buffer
      ;; When dir-locals.el is used to override org-roam-directory,
      ;; org-roam-buffer should have a different local org-roam-directory and
      ;; default-directory, as relative links are relative from the overridden
      ;; org-roam-directory.
      (setq-local org-roam-directory source-org-roam-directory)
      (setq-local default-directory source-org-roam-directory)
      ;; Locally overwrite the file opening function to re-use the
      ;; last window org-roam was called from
      (setq-local org-link-frame-setup
                  (cons '(file . org-roam--find-file) org-link-frame-setup))
      (let ((inhibit-read-only t))
        (erase-buffer)
        (unless (eq major-mode 'org-mode)
          (org-mode))
        (unless org-roam-backlinks-mode
          (org-roam-backlinks-mode))
        (make-local-variable 'org-return-follows-link)
        (setq org-return-follows-link t)
        (run-hooks 'org-roam-buffer-prepare-hook)
        (read-only-mode 1)))))


(cl-defun org-roam-buffer--update-maybe (&key redisplay)
  "Reconstructs `org-roam-buffer'.
This needs to be quick or infrequent, because this is run at
`post-command-hook'.  If REDISPLAY, force an update of
`org-roam-buffer'."
  (let ((buffer (window-buffer)))
    (when (and (or redisplay
                   (not (eq org-roam-buffer--current buffer)))
               (eq 'visible (org-roam-buffer--visibility))
               (buffer-local-value 'buffer-file-truename buffer))
      (setq org-roam-buffer--current buffer)
      (org-roam-buffer-update))))

;;;; Toggling the org-roam buffer
(define-inline org-roam-buffer--visibility ()
  "Return whether the current visibility state of the org-roam buffer.
Valid states are 'visible, 'exists and 'none."
  (declare (side-effect-free t))
  (inline-quote
   (cond
    ((get-buffer-window org-roam-buffer) 'visible)
    ((get-buffer org-roam-buffer) 'exists)
    (t 'none))))

(defun org-roam-buffer--set-width (width)
  "Set the width of `org-roam-buffer' to `WIDTH'."
  (unless (one-window-p)
    (let ((window-size-fixed)
          (w (max width window-min-width)))
      (cond
       ((> (window-width) w)
        (shrink-window-horizontally  (- (window-width) w)))
       ((< (window-width) w)
        (enlarge-window-horizontally (- w (window-width))))))))

(defun org-roam-buffer--set-height (height)
  "Set the height of `org-roam-buffer' to `HEIGHT'."
  (unless (one-window-p)
    (let ((window-size-fixed)
          (h (max height window-min-height)))
      (cond
       ((> (window-height) h)
        (shrink-window  (- (window-height) h)))
       ((< (window-height) h)
        (enlarge-window (- h (window-height))))))))

(defun org-roam-buffer--get-create ()
  "Set up the `org-roam' buffer at `org-roam-buffer-position'."
  (let ((position
         (if (member org-roam-buffer-position '(right left top bottom))
             org-roam-buffer-position
           (let ((text-quoting-style 'grave))
             (lwarn '(org-roam) :error
                    "Invalid org-roam-buffer-position: %s. Defaulting to \\='right"
                    org-roam-buffer-position))
           'right)))
    (save-selected-window
      (-> (get-buffer-create org-roam-buffer)
          (display-buffer-in-side-window
           `((side . ,position)
             (window-parameters . ,org-roam-buffer-window-parameters)))
          (select-window))
      (pcase position
        ((or 'right 'left)
         (org-roam-buffer--set-width
          (round (* (frame-width)  org-roam-buffer-width))))
        ((or 'top  'bottom)
         (org-roam-buffer--set-height
          (round (* (frame-height) org-roam-buffer-height))))))))

(defun org-roam-buffer-activate ()
  "Activate display of the `org-roam-buffer'."
  (interactive)
  (unless org-roam-mode (org-roam-mode))
  (setq org-roam-last-window (get-buffer-window))
  (org-roam-buffer--get-create))

(defun org-roam-buffer-deactivate ()
  "Deactivate display of the `org-roam-buffer'."
  (interactive)
  (setq org-roam-last-window (get-buffer-window))
  (delete-window (get-buffer-window org-roam-buffer)))

(defun org-roam-buffer-toggle-display ()
  "Toggle display of the `org-roam-buffer'."
  (interactive)
  (pcase (org-roam-buffer--visibility)
    ('visible (org-roam-buffer-deactivate))
    ((or 'exists 'none) (org-roam-buffer-activate))))

(provide 'org-roam-buffer)

;;; org-roam-buffer.el ends here