File: org-roam-doctor.el

package info (click to toggle)
org-roam 1.2.3-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 38,912 kB
  • sloc: lisp: 4,508; sh: 741; makefile: 130
file content (318 lines) | stat: -rw-r--r-- 12,126 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
;;; org-roam-doctor.el --- Linter for Org-roam files -*- 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.2.3
;; 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 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)
(require 's)
(require 'dash)
(require 'org-roam-macs)

(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")
(declare-function org-roam--str-to-list "org-roam")
(declare-function org-roam-mode "org-roam")

(defvar org-roam-verbose)
(defvar org-roam-mode)

(defcustom org-roam-doctor-inhibit-startup t
  "Inhibit `org-mode' startup when processing files with `org-doctor'.
When non-nil, images and LaTeX preview will not be generated,
tables will not be aligned, and headlines will not respect
startup visability. This significantly improves performance when
processing multiple files"
  :type 'boolean
  :group '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))))
   (make-org-roam-doctor-checker
    :name 'org-roam-doctor-check-roam-props
    :description "Check #+roam_* properties.")
   (make-org-roam-doctor-checker
    :name 'org-roam-doctor-check-tags
    :description "Check #+roam_tags.")
   (make-org-roam-doctor-checker
    :name 'org-roam-doctor-check-alias
    :description "Check #+roam_alias.")))

(defconst org-roam-doctor--supported-roam-properties
  '("roam_tags" "roam_alias" "roam_key")
  "List of supported Org-roam properties.")

(defun org-roam-doctor-check-roam-props (ast)
  "Checker for detecting invalid #+roam_* properties.
AST is the org-element parse tree."
  (let (reports)
    (org-element-map ast 'keyword
      (lambda (kw)
        (let ((key (org-element-property :key kw)))
          (when (and (string-prefix-p "ROAM_" key t)
                     (not (member (downcase key) org-roam-doctor--supported-roam-properties)))
            (push
             `(,(org-element-property :begin kw)
               ,(concat "Possible mispelled key: "
                        (prin1-to-string key)
                        "\nOrg-roam supports the following keys: "
                        (s-join ", " org-roam-doctor--supported-roam-properties)))
             reports)))))
    reports))

(defun org-roam-doctor-check-tags (ast)
  "Checker for detecting invalid #+roam_tags.
AST is the org-element parse tree."
  (let (reports)
    (org-element-map ast 'keyword
      (lambda (kw)
        (when (string-collate-equalp (org-element-property :key kw) "roam_tags" nil t)
          (let ((tags (org-element-property :value kw)))
            (condition-case nil
                (org-roam--str-to-list tags)
              (error
               (push
                `(,(org-element-property :begin kw)
                  ,(concat "Unable to parse tags: "
                           tags
                           (when (s-contains? "," tags)
                             "\nCheck that your tags are not comma-separated.")))
                reports)))))))
    reports))

(defun org-roam-doctor-check-alias (ast)
  "Checker for detecting invalid #+roam_alias.
AST is the org-element parse tree."
  (let (reports)
    (org-element-map ast 'keyword
      (lambda (kw)
        (when (string-collate-equalp (org-element-property :key kw) "roam_alias" nil t)
          (let ((aliases (org-element-property :value kw)))
            (condition-case nil
              (org-roam--str-to-list aliases)
              (error
               (push
                `(,(org-element-property :begin kw)
                  ,(concat "Unable to parse aliases: "
                           aliases
                           (when (s-contains? "," aliases)
                             "\nCheck that your aliases are not comma-separated.")))
                reports)))))))
    reports))

(defun org-roam-doctor-broken-links (ast)
  "Checker for detecting broken links.
AST is the org-element parse tree."
  (let (reports)
    (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)
                (push
                 `(,(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))
                 reports))))))
    reports))

(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."
  (org-roam-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 for all Org-roam files."
  (interactive "P")
  (unless org-roam-mode (org-roam-mode))
  (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))
          (org-inhibit-startup org-roam-doctor-inhibit-startup))
      (dolist (f files)
        (let ((buf (find-file-noselect f)))
          (org-roam-doctor--check buf checkers)
          (unless (memq buf existing-buffers)
            (save-buffer buf)
            (kill-buffer buf))))))
  (org-roam-message "Linting completed."))

(provide 'org-roam-doctor)

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