branch: elpa/racket-mode
commit 231687403bd56be3b68af833ef4daeb782c4b2a5
Author: Greg Hendershott <[email protected]>
Commit: Greg Hendershott <[email protected]>
Avoid racket--cmd/await with eldoc; fixes #763
Avoid hangs when eldoc is enabled, especially when either:
- People have racket-xp-eldoc-level set to 'summary, in which case we
use the back end to fetch "blueboxes".
- racket-repl-mode does a "type" command to the back end.
Handling eldoc asynchronously does however require us to combine our
two eldoc functions -- one for point and another for sexp head -- into
one, in order to get a result with more common eldoc "strategies" like
the default.
---
racket-custom.el | 2 +-
racket-eldoc.el | 22 --------
racket-repl.el | 119 +++++++++++++++++++++++------------------
racket-xp.el | 160 +++++++++++++++++++++++++++++++------------------------
4 files changed, 157 insertions(+), 146 deletions(-)
diff --git a/racket-custom.el b/racket-custom.el
index ee394fa87d0..7f8258ceb12 100644
--- a/racket-custom.el
+++ b/racket-custom.el
@@ -175,7 +175,7 @@ Used by `racket-xp-eldoc-point' and
`racket-xp-eldoc-sexp-app'.
- Minimal: Only the help-echo string.
-- Summary: Also the signature a.k.a. \"blubox\" from the
+- Summary: Also the signature a.k.a. \"bluebox\" from the
documentation.
- Complete: Also the complete prose documentation.
diff --git a/racket-eldoc.el b/racket-eldoc.el
deleted file mode 100644
index fab1e534971..00000000000
--- a/racket-eldoc.el
+++ /dev/null
@@ -1,22 +0,0 @@
-;;; racket-eldoc.el -*- lexical-binding: t -*-
-
-;; Copyright (c) 2013-2024 by Greg Hendershott.
-;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
-
-;; Author: Greg Hendershott
-;; URL: https://github.com/greghendershott/racket-mode
-
-;; SPDX-License-Identifier: GPL-3.0-or-later
-
-(defun racket--eldoc-do-callback (callback thing str)
- (if str
- (funcall callback
- str
- :thing thing
- :face 'font-lock-function-name-face)
- (funcall callback nil))
- t)
-
-(provide 'racket-eldoc)
-
-;; racket-eldoc.el ends here
diff --git a/racket-repl.el b/racket-repl.el
index fb697940707..28c45fde1b5 100644
--- a/racket-repl.el
+++ b/racket-repl.el
@@ -14,7 +14,6 @@
(require 'racket-complete)
(require 'racket-describe)
(require 'racket-doc)
-(require 'racket-eldoc)
(require 'racket-custom)
(require 'racket-common)
(require 'racket-show)
@@ -1223,61 +1222,78 @@ to supply this quickly enough or at all."
;;; eldoc
+;; See comments in racket-xp.el about async eldoc.
+
(defun racket--repl-in-input-p (pos)
(or (eq 'input (field-at-pos pos))
(when-let (prompt-end (racket--repl-prompt-mark-end))
(<= prompt-end pos))))
-(defun racket-repl-eldoc-point (callback &rest _more)
- "Call eldoc CALLBACK about the identifier at point.
-A value for the variable `eldoc-documentation-functions'. Use
-information from back end \"type\" command."
- (when (and (racket--cmd-open-p)
+(defun racket-repl-eldoc-point-or-sexp-head (callback &rest _more)
+"A value for the variable `eldoc-documentation-functions'.
+
+Obtains documentation for point, if any, else the head of the
+s-expression."
+(when (and (racket--cmd-open-p)
(racket--repl-in-input-p (point)))
- (let ((pos (if (eq 32 (char-before))
- (point)
- (condition-case _
- (let ((pos (save-excursion
- (backward-sexp)
- (point))))
- (if (racket--repl-in-input-p pos)
- pos
- (point)))
- (scan-error (point))))))
- (racket--eldoc-type callback pos))))
-
-(defun racket-repl-eldoc-sexp-app (callback &rest _more)
- "Call eldoc CALLBACK about sexp application around point.
-A value for the variable `eldoc-documentation-functions'. Use
-information from back end \"type\" command."
- (when (and (racket--cmd-open-p)
- (racket--repl-in-input-p (point))
- (> (point) (point-min)))
- (when-let (pos (condition-case _
- (save-excursion
- (backward-up-list)
- (forward-char 1)
- (point))
- (scan-error nil)))
- (racket--eldoc-type callback pos))))
-
-(defun racket--eldoc-type (callback pos)
- "Obtain a \"type\" summary string from the back end.
-This might be a bluebox, or a function signature discovered from
-the surface syntax, or Typed Racket type information."
- (condition-case _
- (let* ((end (save-excursion (progn (goto-char pos) (forward-sexp)
(point))))
- (thing (buffer-substring-no-properties pos end)))
- (when (and thing (not (string= thing "")))
- (when-let (str (racket--cmd/await
+ (let ((point-pos (if (eq 32 (char-before))
+ (point)
+ (condition-case _
+ (let ((pos (save-excursion
+ (backward-sexp)
+ (point))))
+ (if (racket--repl-in-input-p pos)
+ pos
+ (point)))
+ (scan-error (point)))))
+ (head-pos (and (> (point) (point-min))
+ (condition-case _
+ (save-excursion
+ (backward-up-list)
+ (forward-char 1)
+ (point))
+ (scan-error nil)))))
+ (run-with-timer 0 nil
+ #'racket--repl-eldoc-async callback point-pos head-pos))
+ ;; Return non-nil non-string to say we'll make CALLBACK
+ ;; asynchronously.
+ t))
+
+(defun racket--repl-eldoc-async (callback point-pos head-pos)
+ ;; Async expression of: "Try point-pos, else head-pos if non-nil,
+ ;; else fail.".
+ (cl-flet* ((succeed (thing str)
+ (funcall callback
+ str
+ :thing thing
+ :face 'font-lock-function-name-face))
+ (try (pos fail-thunk)
+ (condition-case _
+ (let* ((end (save-excursion
+ (progn (goto-char pos) (forward-sexp)
(point))))
+ (thing (buffer-substring-no-properties pos end)))
+ (if (and thing (not (string= thing "")))
+ (racket--cmd/async
(racket--repl-session-id)
- `(type namespace ,thing)))
- (racket--eldoc-do-callback callback
- thing
- (if (string-match-p "\n" str)
- (concat "\n" str)
- str)))))
- (scan-error nil)))
+ `(type namespace ,thing)
+ (lambda (str)
+ (if str
+ (succeed thing
+ (if (string-match-p "\n" str)
+ (concat "\n" str)
+ str))
+ (funcall fail-thunk))))
+ (funcall fail-thunk)))
+ (scan-error (funcall fail-thunk))))
+ ;; For use below, /not/ by `try'.
+ (fail ()
+ (funcall callback nil)))
+ (try point-pos
+ (lambda ()
+ (if head-pos
+ (try head-pos
+ #'fail)
+ (fail))))))
(defun racket-repl-eldoc-function ()
"A value for the obsolete variable `eldoc-documentation-function'.
@@ -1502,10 +1518,7 @@ identifier bindings and modules from the REPL's
namespace.
(setq-local completion-at-point-functions (list
#'racket-repl-complete-at-point))
(when (boundp 'eldoc-documentation-functions)
(add-hook 'eldoc-documentation-functions
- #'racket-repl-eldoc-sexp-app
- nil t)
- (add-hook 'eldoc-documentation-functions
- #'racket-repl-eldoc-point
+ #'racket-repl-eldoc-point-or-sexp-head
nil t))
(setq-local next-error-function #'racket-repl-next-error)
(racket-repl-read-history)
diff --git a/racket-xp.el b/racket-xp.el
index 4aa13da0a97..a311e0e44f3 100644
--- a/racket-xp.el
+++ b/racket-xp.el
@@ -12,7 +12,6 @@
(require 'racket-scribble-anchor)
(require 'racket-browse-url)
(require 'racket-doc)
-(require 'racket-eldoc)
(require 'racket-repl)
(require 'racket-describe)
(require 'racket-imenu)
@@ -290,10 +289,7 @@ commands directly to whatever keys you prefer.
nil t)
(when (boundp 'eldoc-documentation-functions)
(add-hook 'eldoc-documentation-functions
- #'racket-xp-eldoc-sexp-app
- nil t)
- (add-hook 'eldoc-documentation-functions
- #'racket-xp-eldoc-point
+ #'racket-xp-eldoc-point-or-sexp-head
nil t))
(when (boundp 'eldoc-box-buffer-setup-function)
(setq-local eldoc-box-buffer-setup-function
@@ -319,11 +315,9 @@ commands directly to whatever keys you prefer.
#'racket-xp-pre-redisplay
t)
(when (boundp 'eldoc-documentation-functions)
- (dolist (hook (list #'racket-xp-eldoc-sexp-app
- #'racket-xp-eldoc-point))
- (remove-hook 'eldoc-documentation-functions
- hook
- t)))
+ (remove-hook 'eldoc-documentation-functions
+ #'racket-xp-eldoc-point-or-sexp-head
+ t))
(when (and (boundp 'eldoc-box-buffer-setup-function))
(kill-local-variable eldoc-box-buffer-setup-function)))))
@@ -620,67 +614,93 @@ point."
;; remove only those.
'font-lock-face nil)))))
-(defun racket-xp-eldoc-point (callback &rest _more)
- "Call eldoc CALLBACK about the identifier at point.
-A value for the variable `eldoc-documentation-functions'. Use
-racket-xp-doc and help-echo text properties added by
-`racket-xp-mode'. See `racket-xp-eldoc-level'."
+;;; eldoc
+
+;; We want to take advantage of the newer eldoc API's ability for us
+;; to be "asynchronous". This is good because sometimes we need to
+;; issue a back end command to get "blueboxes". Even when we don't,
+;; because we have a path to the HTML file, (a) it could be on a
+;; remote host and (b) it needs /some/ processing to extract the doc
+;; fragment.
+;;
+;; However that eldoc API requires us to return `t`, meaning that
+;; additional eldoc functions won't be consulted when
+;; `eldoc-documentation-strategy' is something like the default. So we
+;; can't really keep doing the thing where we had two eldoc functions,
+;; one for point and another for a sexp head, if we want to be
+;; "async".
+;;
+;; Instead we have to combine them into one function.
+
+(defun racket-xp-eldoc-point-or-sexp-head (callback &rest _more)
+ "A value for the variable `eldoc-documentation-functions'.
+
+Obtains documentation for point, if any, else the head of the
+s-expression.
+
+See also the customization variable `racket-xp-eldoc-level'."
(when (racket--cmd-open-p)
- (racket--xp-eldoc callback (point))))
-
-(defun racket-xp-eldoc-sexp-app (callback &rest _more)
- "Call eldoc CALLBACK about sexp application around point.
-A value for the variable `eldoc-documentation-functions'. Use
-racket-xp-doc and help-echo text properties added by
-`racket-xp-mode'. See `racket-xp-eldoc-level'."
- (when (and (racket--cmd-open-p)
- (> (point) (point-min)))
- ;; Preserve point during the dynamic extent of the eldoc calls,
- ;; because things like eldoc-box may dismiss the UI if they notice
- ;; point has moved.
- (when-let (pos (condition-case _
- (save-excursion
- (backward-up-list)
- (forward-char 1)
- (point))
- (scan-error nil)))
- ;; Avoid returning the same result as `racket-xp-eldoc-point',
- ;; in case `eldoc-documentation-strategy' composes multiple.
- (cl-flet* ((bounds (pos prop)
- (cdr (racket--get-text-property/bounds pos prop)))
- (same (a b prop)
- (equal (bounds a prop) (bounds b prop))))
- (unless (and (boundp 'eldoc-documentation-functions)
- (member #'racket-xp-eldoc-point
- eldoc-documentation-functions)
- (same pos (point) 'racket-xp-doc)
- (same pos (point) 'help-echo))
- (racket--xp-eldoc callback pos))))))
-
-(defun racket--xp-eldoc (callback pos)
- (pcase (racket--get-text-property/bounds pos 'racket-xp-doc)
- (`((,path ,anchor ,tag) ,beg ,end)
- (let ((thing (buffer-substring-no-properties beg end))
- (help-echo (if-let (s (get-text-property pos 'help-echo))
- (concat s "\n")
- "")))
- (let ((str
- (pcase racket-xp-eldoc-level
- ('summary (racket--cmd/await nil `(bluebox ,tag)))
- ('complete (racket--path+anchor->string path anchor)))))
- (when (or help-echo str)
- (racket--eldoc-do-callback callback thing
- (propertize
- (concat help-echo str)
- 'racket-xp-eldoc t))))))
- (_
- (pcase (racket--get-text-property/bounds pos 'help-echo)
- (`(,str ,beg ,end)
- (let ((thing (buffer-substring-no-properties beg end)))
- (racket--eldoc-do-callback callback thing
- (propertize
- str
- 'racket-xp-eldoc t))))))))
+ (let ((point-pos (point))
+ (head-pos (when (> (point) (point-min))
+ (condition-case _
+ (save-excursion
+ (backward-up-list)
+ (forward-char 1)
+ (point))
+ (scan-error nil)))))
+ (run-with-timer 0 nil
+ #'racket--xp-eldoc-async callback point-pos head-pos))
+ ;; Return non-nil non-string to say we'll make CALLBACK
+ ;; asynchronously.
+ t))
+
+(defun racket--xp-eldoc-async (callback point-pos head-pos)
+ ;; Async expression of: "Try point-pos, else head-pos if non-nil,
+ ;; else fail.".
+ (cl-flet* ((succeed (thing &rest strs)
+ (funcall callback
+ (propertize (string-join strs "\n")
+ 'racket-xp-eldoc t)
+ :thing thing
+ :face 'font-lock-function-name-face))
+ (try (pos fail-thunk)
+ (pcase (racket--get-text-property/bounds pos 'racket-xp-doc)
+ (`((,path ,anchor ,tag) ,beg ,end)
+ (let ((thing (buffer-substring-no-properties beg end))
+ (help-echo (get-text-property pos 'help-echo)))
+ (pcase racket-xp-eldoc-level
+ ('summary
+ (racket--cmd/async
+ nil `(bluebox ,tag)
+ (lambda (str)
+ (if (or help-echo str)
+ (succeed thing help-echo str)
+ (funcall fail-thunk)))))
+ ('complete
+ (let ((str (racket--path+anchor->string path anchor)))
+ (if (or help-echo str)
+ (succeed thing help-echo str)
+ (funcall fail-thunk))))
+ (_ ;minimal
+ (if help-echo
+ (succeed thing help-echo)
+ (funcall fail-thunk))))))
+ (_
+ (pcase (racket--get-text-property/bounds pos 'help-echo)
+ (`(,str ,beg ,end)
+ (let ((thing (buffer-substring-no-properties beg end)))
+ (succeed thing str)))
+ (_
+ (funcall fail-thunk))))))
+ ;; For use below, /not/ by `try'.
+ (fail ()
+ (funcall callback nil)))
+ (try point-pos
+ (lambda ()
+ (if head-pos
+ (try head-pos
+ #'fail)
+ (fail))))))
(defun racket--get-text-property/bounds (pos prop)
"Like `get-text-property' but also returning the bounds."
