diff --git a/init.el b/init.el index ea159b4..1a410b7 100644 --- a/init.el +++ b/init.el @@ -1359,6 +1359,32 @@ If BUFFER is nil, the current buffer is used." when note collect note))) +(defun my/racket-errors-at-point () + "Return a list of error strings describing the Racket errors at point." + (let (out) + (dolist (ov (overlays-at (point))) + (when-let ((face (overlay-get ov 'face))) + (cl-case face + (racket-xp-error-face + (when-let* ((help-echo (get-text-property (point) 'help-echo))) + (push help-echo out))) + (racket-xp-unused-face + (push "no bound occurrences" out))))) + out)) + +(defun my/-add-list-dot-to-string (str) + "Add a dot (•) to the starrt of STR. +If STR has multiple lines, add a space to the start of every other line." + (cl-labels ((rec (acc strs need-add) + (if strs + (rec (cons (concat (if need-add "•" " ") + (car strs)) + acc) + (cdr strs) + nil) + (nreverse acc)))) + (string-join (rec () (string-lines str) t) "\n"))) + (defun my/diagnostic-at-point () "Show the diagnostics under point." (interactive) @@ -1374,14 +1400,15 @@ If BUFFER is nil, the current buffer is used." (cl-callf nconc message (mapcar (lambda (note) (plist-get note :message)) (my/sly-notes-at-point)))) + (when (featurep 'racket-mode) + (cl-callf nconc message (my/racket-errors-at-point))) ;; jinx (when-let* (((bound-and-true-p jinx-mode)) (jinx-msg (jinx--get-overlays (point) (1+ (point))))) (push "misspelled word" message)) (when message (my/floating-tooltip " *my-diagnostic-posframe*" - (mapconcat (lambda (msg) - (concat "•" msg)) + (mapconcat #'my/-add-list-dot-to-string message "\n"))))) (defconst my/consult-flymake-flycheck-narrow @@ -2406,7 +2433,65 @@ Note that this erases the buffer before doing anything." ;; racket (use-package racket-mode :hook ((racket-mode . rainbow-delimiters-mode) - (racket-mode . evil-cleverparens-mode))) + (racket-mode . evil-cleverparens-mode) + (racket-mode . my/racket-xp-mode-if-trusted) + (racket-xp-mode . my/-setup-racket-xp-mode)) + :bind ("C-c E" . my/consult-racket-xp) + :config + (evil-define-key 'normal racket-mode-map + "gz" #'racket-edit-switch-to-repl) + (defun my/racket-xp-mode-if-trusted () + (when (trusted-content-p) + (racket-xp-mode))) + (defun my/-setup-racket-xp-mode () + (setq-local evil-lookup-func #'racket-xp-describe) + (remove-hook 'pre-redisplay-functions #'racket-xp-pre-redisplay t)) + (defconst my/-consult-racket-xp-candidate-rx + (rx (group (* anychar)) ":" (group (+ num)) ":" (group (+ num)) ": " + (group (minimal-match (* anychar))) (or eol eos) + (group (* anychar)))) + (defun my/-consult-racket-xp-propertize-message (message) + "Propertize MESSAGE, a `racket-xp-mode' error message." + (if (string-match my/-consult-racket-xp-candidate-rx message) + (let ((file (match-string 1 message)) + (line (match-string 2 message)) + (col (match-string 3 message)) + (line1 (match-string 4 message)) + (other-lines (match-string 5 message))) + (format "%s %s:%s %s %s" + file + (propertize line 'face 'font-lock-constant-face) + (propertize col 'face 'font-lock-constant-face) + line1 + (propertize other-lines 'face 'font-lock-comment-face))) + message)) + (defun my/consult-racket-xp-candidates () + "Return Consult candidates for `racket-xp-mode'." + (cl-map 'list (pcase-lambda (`(,_ ,pos ,msg)) + (propertize (my/-consult-racket-xp-propertize-message msg) + 'consult--candidate pos)) + racket--xp-errors)) + (defun my/consult-racket-xp-candidates-for-project (&optional project) + (mapcan (lambda (buf) + (with-current-buffer buf + (my/consult-racket-xp-candidates))) + (if-let* ((proj (or project (project-current)))) + (project-buffers proj) + (list (current-buffer))))) + (defun my/consult-racket-xp (&optional project) + (interactive "P") + (consult--read + (consult--with-increased-gc + (if project + (my/consult-racket-xp-candidates-for-project) + (my/consult-racket-xp-candidates))) + :prompt "Error: " + :category 'racket-xp + :history t + :require-match t + :sort nil + :lookup #'consult--lookup-candidate + :state (consult--jump-state)))) ;; jupyter (use-package jupyter