Better racker support

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