(feat): add org-roam-doctor (#570)

`org-roam-doctor` provides a diagnostic tool for checking an Org-roam
file for things that are broken. Currently implemented is a check for
broken links, and methods to fix them. The checker is designed to be
extensible.

CHANGELOG.md

@@ -18,6 +18,7 @@
 * [#538](https://github.com/org-roam/org-roam/pull/538) Optionally use text in first headline as title
 * [#553](https://github.com/org-roam/org-roam/pull/553) Add prefix argument to `org-roam-db-build-cache` for forcing rebuilds
 * [#560](https://github.com/org-roam/org-roam/pull/560) Apply 'error face to distinguish broken links
+* [#570](https://github.com/org-roam/org-roam/pull/570) Add `org-roam-doctor` to diagnose org-roam files
 
 ## 1.1.0 (21-04-2020)
 

doc/org-roam.org

@@ -663,6 +663,38 @@ where =template= is the template key for a template in
 =org-roam-capture-ref-templates= (see [[*The Templating System][The Templating System]]). These templates
 should contain a =#+ROAM_KEY: ${ref}= in it.
 
+* Diagnosing and Repairing Files
+
+Org-roam provides a utility for diagnosing and repairing problematic files via
+=org-roam-doctor=. By default, =org-roam-doctor= runs the check across all Org-roam
+files, and this can take some time. To run the check only for the current file,
+run =C-u M-x org-roam-doctor=.
+
+- Function: org-roam-doctor &optional this-buffer
+
+  Perform a check on Org-roam files to ensure cleanliness. If THIS-BUFFER, run
+  the check only for the current buffer.
+
+The checks run are defined in =org-roam-doctor--checkers=. Each checker is an instance of =org-roam-doctor-checker=. To define a checker, use =make-org-roam-doctor-checker=. Here is a sample definition:
+
+#+BEGIN_SRC emacs-lisp
+(make-org-roam-doctor-checker
+    :name 'org-roam-doctor-broken-links
+    :description "Fix broken links."
+    :actions '(("d" . ("Unlink" . org-roam-doctor--remove-link))
+               ("r" . ("Replace link" . org-roam-doctor--replace-link))
+               ("R" . ("Replace link (keep label)" . org-roam-doctor--replace-link-keep-label))))
+#+END_SRC
+
+The =:name= property is the name of the function run. The function takes in the
+Org parse tree, and returns a list of =(point error-message)=. =:description= is a
+short description of what the checker does. =:actions= is an alist containing
+elements of the form =(char . (prompt . function))=. These actions are defined per
+checker, to perform autofixes for the errors. For each error detected,
+=org-roam-doctor= will move the point to the current error, and pop-up a help
+window displaying the error message, as well as the list of actions that can be
+taken provided in =:actions=.
+
 * Keystroke Index
 :PROPERTIES:
 :APPENDIX:   t

org-roam-doctor.el

@@ -0,0 +1,225 @@
+;;; org-roam-doctor.el --- Rudimentary Roam replica with Org-mode -*- coding: utf-8; lexical-binding: t; -*-
+;;
+;; Copyright © 2020 Jethro Kuan <jethrokuan95@gmail.com>
+
+;; Author: Jethro Kuan <jethrokuan95@gmail.com>
+;; URL: https://github.com/jethrokuan/org-roam
+;; Keywords: org-mode, roam, convenience
+;; Version: 1.1.0
+;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (s "1.12.0") (org "9.3") (emacsql "3.0.0") (emacsql-sqlite "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 `org-roam-doctor', a utility for diagnosing and fixing
+;; Org-roam files. Running `org-roam-doctor' launches a list of checks defined
+;; by `org-roam-doctor--checkers'. Every checker is an instance of
+;; `org-roam-doctor-checker'.
+;;
+;; Each checker is given the Org parse tree (AST), and is expected to return a
+;; list of errors. The checker can also provide "actions" for auto-fixing errors
+;; (see `org-roam-doctor--remove-link' for an example).
+;;
+;; The UX experience is inspired by both org-lint and checkdoc, and their code
+;; is heavily referenced.
+;;
+;;; Code:
+;; Library Requires
+(require 'cl-lib)
+(require 'org)
+(require 'org-element)
+
+(declare-function org-roam-insert "org-roam")
+(declare-function org-roam--get-roam-buffers "org-roam")
+(declare-function org-roam--list-all-files "org-roam")
+(declare-function org-roam--org-roam-file-p "org-roam")
+
+(cl-defstruct (org-roam-doctor-checker (:copier nil))
+  (name 'missing-checker-name)
+  (description "")
+  (actions nil))
+
+(defconst org-roam-doctor--checkers
+  (list
+   (make-org-roam-doctor-checker
+    :name 'org-roam-doctor-broken-links
+    :description "Fix broken links."
+    :actions '(("d" . ("Unlink" . org-roam-doctor--remove-link))
+               ("r" . ("Replace link" . org-roam-doctor--replace-link))
+               ("R" . ("Replace link (keep label)" . org-roam-doctor--replace-link-keep-label))))))
+
+(defun org-roam-doctor-broken-links (ast)
+  "Checker for detecting broken links.
+AST is the org-element parse tree."
+  (org-element-map ast 'link
+    (lambda (l)
+      (when (equal "file" (org-element-property :type l))
+        (let ((file (org-element-property :path l)))
+          (or (file-exists-p file)
+              (file-remote-p file)
+               `(,(org-element-property :begin l)
+                 ,(format (if (org-element-lineage l '(link))
+                              "Link to non-existent image file \"%s\"\
+ in link description"
+                            "Link to non-existent local file \"%s\"")
+                          file))))))))
+
+(defun org-roam-doctor--check (buffer checkers)
+  "Check BUFFER for errors.
+CHECKERS is the list of checkers used."
+  (with-current-buffer buffer
+    (save-excursion
+      (goto-char (point-min))
+      (let* ((ast (org-element-parse-buffer))
+             (errors (sort (cl-mapcan
+                            (lambda (c)
+                              (mapcar
+                               (lambda (report)
+                                 (list (set-marker (make-marker) (car report))
+                                       (nth 1 report) c))
+                               (save-excursion
+                                 (funcall
+                                  (org-roam-doctor-checker-name c)
+                                  ast))))
+                            checkers)
+                           #'car-less-than-car)))
+        (dolist (e errors)
+          (pcase-let ((`(,m ,msg ,checker) e))
+            (switch-to-buffer buffer)
+            (goto-char m)
+            (org-reveal)
+            (undo-boundary)
+            (org-roam-doctor--resolve msg checker)
+            (set-marker m nil)))
+        errors))))
+
+;;; Actions
+(defun org-roam-doctor--recursive-edit ()
+  "Launch into a recursive edit."
+  (message "When you're done editing press C-M-c to continue.")
+  (recursive-edit))
+
+(defun org-roam-doctor--skip ()
+  "Skip the current error."
+  (message "Skipping..."))
+
+(defun org-roam-doctor--replace-link ()
+  "Replace the current link with a new link."
+  (save-match-data
+    (unless (org-in-regexp org-link-bracket-re 1)
+      (user-error "No link at point"))
+    (let ((orig (buffer-string))
+          (p (point)))
+      (condition-case nil
+          (save-excursion
+            (replace-match "")
+            (org-roam-insert))
+        (quit (progn
+                (replace-buffer-contents orig)
+                (goto-char p)))))))
+
+(defun org-roam-doctor--replace-link-keep-label ()
+  "Replace the current link with a new link, keeping the current link's label."
+  (save-match-data
+    (unless (org-in-regexp org-link-bracket-re 1)
+      (user-error "No link at point"))
+    (let ((orig (buffer-string))
+          (p (point)))
+      (condition-case nil
+          (save-excursion
+            (let ((label (if (match-end 2)
+                             (match-string-no-properties 2)
+                           (org-link-unescape (match-string-no-properties 1)))))
+              (replace-match "")
+              (org-roam-insert nil nil label)))
+        (quit (progn
+                (replace-buffer-contents orig)
+                (goto-char p)))))))
+
+(defun org-roam-doctor--remove-link ()
+  "Unlink the text at point."
+  (unless (org-in-regexp org-link-bracket-re 1)
+    (user-error "No link at point"))
+  (save-excursion
+    (let ((label (if (match-end 2)
+                     (match-string-no-properties 2)
+                   (org-link-unescape (match-string-no-properties 1)))))
+      (delete-region (match-beginning 0) (match-end 0))
+      (insert label))))
+
+(defun org-roam-doctor--resolve (msg checker)
+  "Resolve an error.
+MSG is the error that was found, which is displayed in a help buffer.
+CHECKER is a org-roam-doctor checker instance."
+  (let ((actions (org-roam-doctor-checker-actions checker))
+        c)
+    (push '("e" . ("Edit" . org-roam-doctor--recursive-edit)) actions)
+    (push '("s" . ("Skip" . org-roam-doctor--skip)) actions)
+    (with-output-to-temp-buffer "*Org-roam-doctor Help*"
+      (mapc #'princ
+            (list "Error message:\n   " msg "\n\n"))
+      (dolist (action actions)
+        (princ (format "[%s]: %s\n"
+                       (car action)
+                       (cadr action))))
+      (princ "\n\n"))
+    (shrink-window-if-larger-than-buffer
+     (get-buffer-window "*Org-roam-doctor Help*"))
+    (message "Press key for command:")
+    (unwind-protect
+        (progn
+          (cl-loop
+           do (setq c (char-to-string (read-char-exclusive)))
+           until (assoc c actions)
+           do (message "Please enter a valid key for command:"))
+          (funcall (cddr (assoc c actions)))
+          (redisplay))
+      (when (get-buffer-window "*Org-roam-doctor Help*")
+        (delete-window (get-buffer-window "*Org-roam-doctor Help*"))
+        (kill-buffer "*Org-roam-doctor Help*")))))
+
+;;;###autoload
+(defun org-roam-doctor (&optional checkall)
+  "Perform a check on the current buffer to ensure cleanliness.
+If CHECKALL, run the check only for all Org-roam files."
+  (interactive "P")
+  (let ((files (if checkall
+                  (org-roam--list-all-files)
+                (unless (org-roam--org-roam-file-p)
+                  (user-error "Not in an org-roam file"))
+                `(,(buffer-file-name)))))
+    (org-roam-doctor-start files org-roam-doctor--checkers)))
+
+(defun org-roam-doctor-start (files checkers)
+  "Lint FILES using CHECKERS."
+  (save-window-excursion
+    (let ((existing-buffers (org-roam--get-roam-buffers)))
+      (dolist (f files)
+        (let ((buf (find-file-noselect f)))
+          (with-current-buffer buf
+            (org-roam-doctor--check buf checkers))
+          (unless (memq buf existing-buffers)
+            (save-buffer buf)
+            (kill-buffer buf))))))
+  (message "Linting completed."))
+
+(provide 'org-roam-doctor)
+
+;;; org-roam-doctor.el ends here

org-roam.el

@@ -52,6 +52,7 @@
 (require 'org-roam-graph)
 (require 'org-roam-completion)
 (require 'org-roam-dailies)
+(require 'org-roam-doctor)
 
 ;; To detect cite: links
 (require 'org-ref nil t)
@@ -443,7 +444,7 @@ Examples:
                     ("^_" . "")  ;; remove starting underscore
                     ("_$" . "")))  ;; remove ending underscore
            (slug (-reduce-from #'cl-replace (strip-nonspacing-marks title) pairs)))
-      (s-downcase slug))))
+      (downcase slug))))
 
 ;;; Interactive Commands
 (defun org-roam--format-link-title (title)
@@ -466,11 +467,12 @@ Examples:
                        target))
      description)))
 
-(defun org-roam-insert (prefix &optional filter-fn)
+(defun org-roam-insert (&optional lowercase filter-fn description)
   "Find an Org-roam file, and insert a relative org link to it at point.
-If PREFIX, downcase the title before insertion.
+If LOWERCASE, downcase the title before insertion.
 FILTER-FN is the name of a function to apply on the candidates
-which takes as its argument an alist of path-completions.  See
+which takes as its argument an alist of path-completions.
+If DESCRIPTION is provided, use this as the link label. See
 `org-roam--get-title-path-completions' for details."
   (interactive "P")
   (let* ((region (and (region-active-p)
@@ -485,11 +487,11 @@ which takes as its argument an alist of path-completions.  See
                              it)))
          (title (org-roam-completion--completing-read "File: " completions
                                                       :initial-input region-text))
-         (region-or-title (or region-text title))
+         (description (or description region-text title))
          (target-file-path (cdr (assoc title completions)))
-         (link-description (org-roam--format-link-title (if prefix
+         (link-description (org-roam--format-link-title (if lowercase
-                                                            (downcase region-or-title)
+                                                            (downcase description)
-                                                          region-or-title))))
+                                                          description))))
     (if (and target-file-path
              (file-exists-p target-file-path))
         (progn