diff --git a/CHANGELOG.md b/CHANGELOG.md index c0bae1d..41c70e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,16 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). ## [Unreleased] +### Changed + +- [#2](https://github.com/nrepl/neat/pull/2): Handle the less common parts of the protocol properly: + - Late and id-less output shows up above the REPL prompt, and so do the results of source-buffer evals. + - Error statuses that come without an `err` (`namespace-not-found`, `unknown-session`, `unknown-op`) are reported, and an `unknown-session` reply offers to clone a new session. + - The stdin prompt can send end of input with `C-c C-d`. + - Completion, eldoc and interrupt check `describe` first, and completion and eldoc back off on servers that answer one request at a time. + - Quitting the REPL closes its session on the server. + - Requests still pending when a connection drops get a `connection-closed` status instead of `interrupted`, and `neat-bencode-encode` signals on nil. + ## [0.1.0] - 2026-05-20 ### Added diff --git a/README.md b/README.md index 3f6042f..64899f2 100644 --- a/README.md +++ b/README.md @@ -33,25 +33,24 @@ edges - this is the start of the road, not the end. ecosystem rather than a Clojure-only protocol. That effort has three strands: -1. **An official nREPL specification.** Today the [nREPL][nrepl] project +1. An official nREPL specification. Today the [nREPL][nrepl] project is the de facto spec; a formal version is being drafted at [nrepl/spec.nrepl.org][spec]. `neat` aims to keep pressure on the spec to stay genuinely language-agnostic by being a client that refuses to silently assume Clojure. -2. **Reference clients.** A spec without independent client +2. Reference clients. A spec without independent client implementations is wishful thinking. `neat` is one such reference client, intentionally built on Emacs builtins and free of Clojure-specific helpers, so it can act as a baseline for what "compliant" should mean on the client side. -3. **A compatibility test suite.** The parameterised integration suite - under [`test/neat-integration-test.el`](test/neat-integration-test.el) - already runs the same assertions against multiple servers (Clojure, - Babashka, Basilisp), and divergences between them get surfaced as - real findings rather than mysterious bugs. The long-term goal is - to grow this into a portable suite any nREPL server can self-check - against. +3. A compatibility test suite. That one lives in its own project, + [proof][proof]. It talks to a server the way clients do, runs a set + of checks and tells you what's broken and which clients it breaks. + If you work on an nREPL server, that's the tool to reach for. + neat's own integration suite only tests the client. [spec]: https://github.com/nrepl/spec.nrepl.org +[proof]: https://github.com/nrepl/proof ## Installation @@ -205,23 +204,28 @@ the source (Clojure's `(ns foo.bar)`, etc.), swap in a parser via ### Eldoc, completion, or `M-.` quietly do nothing The CAPF, eldoc backend, and xref backend all rely on the standard -`completions` and `lookup` nREPL ops. If your server doesn't implement -them, our sync helpers return nil and we defer silently - that's by -design, a language-agnostic client can't assume anything. +`completions` and `lookup` nREPL ops. neat checks the ops the server +lists in its `describe` reply, and when one of them is missing these +features stay out of the way - that's by design, a language-agnostic +client can't assume anything. Diagnosis: turn on the message log (next-to-last entry below) and -look for `unknown-op` in the status. +look at the `ops` in the `describe` reply, or for `unknown-op` in a +status. ### Evaluation just sits there Three usual suspects: - The eval is reading from stdin. Look at the minibuffer for a - `stdin:` prompt and answer it. `C-g` interrupts the read. + `stdin` prompt and answer it, REPL buffer or not. `C-c C-d` there + sends end-of-file, and `C-g` interrupts the eval (or sends + end-of-file, if the server can't interrupt). - The connection died. The mode-line shows `[closed]` and a `;; connection closed` line appears in the REPL buffer. - The eval is actually running, just slowly. `C-c C-c` in the REPL - (or `C-c C-k` in a source buffer) sends an `interrupt` op. + (or `C-c C-k` in a source buffer) sends an `interrupt` op. Not every + server has one, and neat tells you when yours doesn't. ### Evaluation lands in the wrong namespace @@ -234,6 +238,10 @@ its current namespace is. To pin a source buffer: - Or swap `neat-buffer-ns-function` for one that derives the ns from the buffer (parsing a `(ns ...)` form, reading file metadata, etc.). +A namespace the server doesn't know (a typo in `neat-ns`, say) shows +up as a `;; namespace not found: ...` line in the REPL, or in the echo +area when there's no REPL buffer. + ### `M-x neat` doesn't autofill the port The port comes from the nearest `.nrepl-port` file walking up from @@ -309,31 +317,19 @@ eldev lint # lint eldev test # run Buttercup suites ``` -The default suite is the fast one. There's also an integration suite that -boots real nREPL servers as subprocesses and exercises the full client. -It's gated behind an env var since starting a server adds a few seconds: +The default suite is the fast one. There's also an integration suite +that starts an nREPL server (`nrepl/nrepl`, through the Clojure CLI) +and drives the client and the REPL buffer end to end: rendering, +stdin, interrupts, error statuses and late output. It's gated behind +an env var since starting the JVM adds a few seconds, and it's +skipped when `clojure` isn't on your PATH: ``` NEAT_INTEGRATION=1 eldev test ``` -The integration suite walks `neat-it--server-impls` in -`test/neat-integration-test.el` and registers a block per implementation -that's installed on PATH. Currently: - -| Implementation | Executable | How to install | -|----------------|------------|----------------| -| Clojure (`nrepl/nrepl`) | `clojure` | [clojure.org/guides/install_clojure](https://clojure.org/guides/install_clojure) | -| [Babashka](https://babashka.org) | `bb` | `brew install borkdude/brew/babashka` | -| [Basilisp](https://basilisp.readthedocs.io) (Python) | `basilisp` | `pipx install basilisp` | -| [let-go](https://github.com/nooga/let-go) (Go) | `let-go` | `go install github.com/nooga/let-go@latest` | - -Add more entries to the list to teach the suite about your favorite -nREPL implementation. Most servers just need an executable that prints -a port banner on stdout; for ones that can't or won't announce an -OS-assigned port (let-go, currently), the entry can supply a -`:port-fn` that pre-allocates a free port for the framework to pass -in. +The suite tests neat, not the server. To find out how well a server +speaks nREPL, run [proof][proof] against it. ## License diff --git a/doc/design.md b/doc/design.md index e49fbf3..1669763 100644 --- a/doc/design.md +++ b/doc/design.md @@ -94,12 +94,22 @@ The single-callback model is what every responding nREPL client we surveyed (monroe, CIDER, vim-fireplace) uses. We're not breaking that pattern. +Some messages don't belong to any pending request. Servers send `out` +with no `id` at all, or keep sending it for a request that's already +`done` (think of a `future` that prints after the eval has returned). +Those go to `neat-unhandled-message-functions`, and the REPL buffer +prints their output above the prompt. + ### Op discovery via `describe`, no hardcoded Clojurisms nREPL is a protocol; servers advertise the ops they implement via the -`describe` op. neat sends `describe` on connect and stashes the response -on the connection. UI-level features like CAPF and eldoc consult that -capability map and silently no-op when the op they need is missing. +`describe` op. neat sends `describe` on connect and keeps the response +on the connection, and `neat-op-supported-p` answers from it. +Completion, eldoc and xref quietly step aside when the op they need is +missing. The doc lookup and interrupt commands tell you instead, as +you asked for them directly. A server that lists no ops at all gets +the benefit of the doubt, so we just send the request and see what +comes back. There are no hardcoded `clojure.repl/doc` forms, no assumption the server runs on a JVM, no Leiningen or Clojure CLI defaults baked into the connect command. @@ -168,19 +178,16 @@ Supporting Emacs 27 would mean fallbacks for each of those and worse UX where the modern API does the right thing. Not worth it for a young project. -## Integration testing as a compatibility tool - -The parameterised suite at `test/neat-integration-test.el` runs the -same assertions against every nREPL implementation whose executable -is on PATH. Today: Clojure (`nrepl/nrepl`), Babashka, Basilisp. +## Integration tests -This isn't just nice-to-have; it's a first step toward a real nREPL -compatibility test suite. The contract under test is what we believe -any conformant server should support, and concrete divergences (for -example, Basilisp chunking `(println "hi")` into two `out` messages -where Clojure batches them into `"hi\n"`) are exactly the findings -that should feed back into the nREPL specification work. +The suite at `test/neat-integration-test.el` runs neat end to end +against the reference nREPL server. It types into a real REPL buffer +and checks what comes back, which covers the parts unit tests can +only fake: the stdin round trip, interrupts, error statuses and +output that arrives after `done`. -Adding a new implementation is a single plist entry in -`neat-it--server-impls`: name, executable, command builder, and a -regex for the port banner. +It used to run the same checks against several servers, with the +idea of growing into a compatibility suite for nREPL servers. That +job has moved to [proof](https://github.com/nrepl/proof), which is +built for it, so this suite sticks to one server and tests the +client. diff --git a/neat-bencode.el b/neat-bencode.el index f4f04aa..13729d6 100644 --- a/neat-bencode.el +++ b/neat-bencode.el @@ -38,13 +38,21 @@ OBJ may be: - an integer - a string (encoded as a bytestring; multibyte strings are UTF-8 encoded) - - a list of encodable values + - a list or vector of encodable values - an alist whose keys are strings or symbols (encoded as a bencode dict with keys sorted lexicographically by their byte representation) +A list whose every element is a cons headed by a string or symbol +looks like an alist, so it goes out as a dict; use a vector to send +a list of lists. nil is rejected rather than guessed at, since it +could stand for an empty list, an empty dict or a missing value. +Send [] for an empty list. + Signals `neat-bencode-error' for values that do not match any of the above." (cond + ((null obj) + (signal 'neat-bencode-error (list "cannot encode nil"))) ((integerp obj) (neat-bencode--ascii (format "i%de" obj))) ((stringp obj) @@ -52,7 +60,7 @@ above." (concat (neat-bencode--ascii (number-to-string (length bytes))) (neat-bencode--ascii ":") bytes))) - ((neat-bencode--alistp obj) + ((neat-bencode-dict-p obj) (let ((pairs (cl-sort (mapcar (lambda (cell) (cons (neat-bencode--key-string (car cell)) (cdr cell))) @@ -65,7 +73,7 @@ above." (neat-bencode-encode (cdr cell)))) pairs) ,(neat-bencode--ascii "e"))))) - ((listp obj) + ((or (listp obj) (vectorp obj)) (apply #'concat `(,(neat-bencode--ascii "l") ,@(mapcar #'neat-bencode-encode obj) @@ -91,10 +99,11 @@ above." ((symbolp k) (symbol-name k)) (t (signal 'neat-bencode-error (list "non-string dict key" k))))) -(defun neat-bencode--alistp (obj) - "Return non-nil if OBJ has the shape of a dict-style alist. -That is, every cell of OBJ is a cons whose car is a string or symbol. -An empty list is not an alist (it encodes as a list)." +(defun neat-bencode-dict-p (obj) + "Return non-nil if OBJ has the shape of a bencode dict. +That is, every cell of OBJ is a cons whose car is a string or symbol: +what `neat-bencode-encode' sends as a dict, and what a decoded dict +looks like. An empty list is not a dict (it encodes as a list)." (and (consp obj) (consp (car obj)) (cl-every (lambda (cell) diff --git a/neat-client.el b/neat-client.el index 41a02a4..037ace3 100644 --- a/neat-client.el +++ b/neat-client.el @@ -54,6 +54,15 @@ the server going away. Use to update buffers that reference the connection (the REPL buffer adds a `connection closed' marker this way).") +(defvar neat-unhandled-message-functions nil + "Abnormal hook run for messages that no pending callback claims. +Each function is called with two arguments, the `neat-connection' and +the response dict. That covers messages with no `id', ids that were +never registered, and anything a server sends for a request after its +`done' (nREPL and Babashka both keep sending `out' from a `future' +that outlives the eval that started it). The REPL buffer uses this +to show such output above its prompt.") + (defun neat-active-connection () "Return the active connection for the current buffer, or nil. Prefers `neat-current-connection' when set buffer-locally and still @@ -74,12 +83,17 @@ Slots: PROCESS - the underlying network process HOST, PORT - the address we connected to SESSION - the nREPL session id (set by `neat-clone-session') + NS - the namespace the REPL last reported, if any CAPABILITIES - parsed response from a `describe' op PENDING - hash table mapping request id -> callback function + EVALS - ids of `eval' and `load-file' requests awaiting `done' + STALLED - when a tooling request last timed out behind an eval + (a `float-time'), or nil; see `neat-tooling-stalled-p' NEXT-ID - integer counter used to mint fresh request ids RECV-BUFFER - accumulated, undecoded bytes from the wire" - process host port session capabilities + process host port session ns capabilities (pending (make-hash-table :test 'equal)) + evals stalled (next-id 0) (recv-buffer (unibyte-string))) @@ -115,7 +129,7 @@ double-fire." (let ((proc (neat-connection-process conn))) (if (process-live-p proc) (delete-process proc) - (neat-client--cleanup conn "disconnected")))) + (neat-client--cleanup conn)))) (defun neat-connection-live-p (conn) "Return non-nil if CONN's underlying process is alive." @@ -282,19 +296,26 @@ MESSAGE is an alist of op fields (e.g. `((op . \"eval\") (code . \"...\"))'). A unique `id' field is added automatically. CALLBACK, if given, is called with the parsed response dict for every response sharing the assigned id. Callers should inspect the `status' field to detect -completion -- `done' indicates the server is finished with this +completion: `done' indicates the server is finished with this request, after which the callback is unregistered. +If the connection goes away before `done' arrives, CALLBACK gets one +last response made up by neat itself, with status +\(\"done\" \"connection-closed\") and nothing else. No server sends +`connection-closed'; it only ever comes from the client. + Returns the assigned id (a string)." (unless (neat-connection-live-p conn) (user-error "Neat: connection is not live")) (let* ((id (number-to-string (cl-incf (neat-connection-next-id conn)))) - (with-id (cons (cons "id" id) message))) + (with-id (cons (cons "id" id) message)) + ;; Encode first, so a message that can't be encoded leaves no + ;; callback or log entry behind. + (bytes (neat-bencode-encode with-id))) (when callback (puthash id callback (neat-connection-pending conn))) (neat-client--log conn :out with-id) - (process-send-string (neat-connection-process conn) - (neat-bencode-encode with-id)) + (process-send-string (neat-connection-process conn) bytes) id)) @@ -318,9 +339,23 @@ CALLBACK, if given, fires for each response message." (neat-send conn '((op . "describe")) (lambda (resp) - (setf (neat-connection-capabilities conn) resp) + ;; A `done' sent on its own mustn't wipe out the ops. + (when (or (assoc "ops" resp) + (not (neat-connection-capabilities conn))) + (setf (neat-connection-capabilities conn) resp)) (when callback (funcall callback resp))))) +(defun neat-op-supported-p (conn op) + "Return non-nil if CONN's server advertises the op named OP. +Looks at the `ops' of the stored `describe' reply, which servers send +either as a dict keyed by op name or as a plain list of names. With +no reply yet, or one that lists no ops, every op counts as supported: +better to try and get `unknown-op' back than to turn a feature off +on a guess." + (let ((ops (neat-bencode-get (neat-connection-capabilities conn) "ops"))) + (or (not (consp ops)) + (and (if (consp (car ops)) (assoc op ops) (member op ops)) t)))) + (defun neat-eval (conn code &rest plist) "Send an `eval' op on CONN to run CODE. @@ -344,7 +379,7 @@ PLIST is a property list of optional fields: ,@(when file `((file . ,file))) ,@(when line `((line . ,line))) ,@(when column `((column . ,column)))))) - (neat-send conn msg callback))) + (neat-client--track-eval conn (neat-send conn msg callback)))) (defun neat-load-file (conn file-contents &rest plist) "Send a `load-file' op on CONN carrying FILE-CONTENTS. @@ -366,7 +401,55 @@ to errors and other diagnostics." ,@(when file-path `((file-path . ,file-path))) ,@(when file-name `((file-name . ,file-name))) ,@(when session `((session . ,session)))))) - (neat-send conn msg callback))) + (neat-client--track-eval conn (neat-send conn msg callback)))) + +(defun neat-client--track-eval (conn id) + "Note request ID as an eval in flight on CONN and return ID." + (push id (neat-connection-evals conn)) + id) + +(defun neat-eval-pending-p (conn) + "Return non-nil while an `eval' or `load-file' on CONN awaits `done'." + (and (neat-connection-evals conn) t)) + +(defcustom neat-tooling-probe-interval 5 + "Seconds between probes of a connection whose tooling requests stall. +See `neat-tooling-stalled-p'." + :type 'number + :group 'neat) + +(defun neat-tooling-stalled-p (conn) + "Return non-nil if tooling requests on CONN should hold off for now. +Some servers (Babashka among them) work through one request at a time +per connection, so anything sent behind a running eval waits for it +to finish. There's no telling from `describe', so this goes by what +happened: a tooling request that timed out while an eval was in +flight marks CONN, and the mark goes once no evals are left or a +tooling request does get answered mid-eval. Servers that answer +tooling ops while an eval runs, nREPL included, never get marked. + +So the mark can go while the eval keeps running, or when its `done' +never comes, the answer is nil once every +`neat-tooling-probe-interval' seconds: that lets one request through +to see whether the server answers now. Ask right before sending." + (let ((since (neat-connection-stalled conn))) + (cond + ((not since) nil) + ((not (neat-eval-pending-p conn)) + (setf (neat-connection-stalled conn) nil) + nil) + ((< (- (float-time) since) neat-tooling-probe-interval) t) + (t + (setf (neat-connection-stalled conn) (float-time)) + nil)))) + +(defun neat-client--note-tooling (conn answered) + "Update CONN's stall mark after a tooling request. +ANSWERED nil means the request timed out, which only counts while an +eval is in flight; see `neat-tooling-stalled-p'." + (cond (answered (setf (neat-connection-stalled conn) nil)) + ((neat-eval-pending-p conn) + (setf (neat-connection-stalled conn) (float-time))))) (defun neat-stdin (conn input &rest plist) "Send a `stdin' op on CONN delivering INPUT to a paused eval. @@ -401,11 +484,39 @@ for each response message." (defun neat-close-session (conn &optional session callback) "Send a `close' op on CONN to close SESSION (defaults to the current one). +Closing CONN's current session also clears it from CONN, so later +requests don't go out with a session the server has thrown away. CALLBACK, if given, fires for each response message." (let* ((sess (or session (neat-connection-session conn))) (msg `((op . "close") ,@(when sess `((session . ,sess)))))) - (neat-send conn msg callback))) + (prog1 (neat-send conn msg callback) + (when (and sess (equal sess (neat-connection-session conn))) + (setf (neat-connection-session conn) nil))))) + +(defun neat-response-error (resp &optional explained) + "Return a short description of the error status in RESP, or nil. +Picks out the statuses servers send in place of any output, which +would otherwise leave nothing to see: `namespace-not-found', +`unknown-session', `unknown-op', and a bare `error' with no `err' or +`ex' next to it. EXPLAINED non-nil means the request already showed +an `err' or `ex' earlier, so a bare `error' needs no line of its own. +Statuses are matched by membership, as servers pair them with `done' +and `error' in no fixed order." + (let ((status (neat-bencode-get resp "status"))) + (cl-flet ((detailed (text key) + (let ((detail (neat-bencode-get resp key))) + (if (stringp detail) (format "%s: %s" text detail) text)))) + (cond + ((member "namespace-not-found" status) + (detailed "namespace not found" "ns")) + ((member "unknown-session" status) "unknown session") + ((member "unknown-op" status) (detailed "unknown op" "op")) + ((and (member "error" status) + (not explained) + (not (neat-bencode-get resp "err")) + (not (neat-bencode-get resp "ex"))) + "error"))))) (defun neat-completions (conn prefix &optional ns callback) "Send a `completions' op on CONN for PREFIX (and optionally NS). @@ -434,44 +545,147 @@ CALLBACK, if given, fires for each response." ;; eldoc) can use them. They pump `accept-process-output' until the ;; response arrives or the timeout fires. -(defun neat-client--block-for-done (conn timeout done-p) - "Pump CONN's process output until calling DONE-P yields non-nil. -Give up after TIMEOUT seconds." - (let ((deadline (+ (float-time) timeout))) - (while (and (not (funcall done-p)) - (< (float-time) deadline)) - (accept-process-output (neat-connection-process conn) 0.05)))) +(defun neat-client--request-sync (conn timeout send) + "Send a request with SEND and block until CONN's server is done with it. +SEND is called with the callback to hand to the op function it calls, +and must return that request's id, as the op functions do. Pumps +CONN's process output for up to TIMEOUT seconds. + +Returns the responses that arrived, in the order they came: all of +them once `done' arrives, or whatever came before TIMEOUT ran out. +If the connection went away first, the last one is neat's own +`connection-closed' reply (see `neat-send'). Giving up, on the +timeout or on \\[keyboard-quit], unregisters the callback, so a reply +that never comes doesn't leave it behind in the pending table. Only +a real timeout counts toward `neat-tooling-stalled-p'." + (let ((deadline (+ (float-time) timeout)) + responses done) + (let ((id (funcall send + (lambda (resp) + (push resp responses) + (when (member "done" (neat-bencode-get resp "status")) + (setq done t)))))) + (unwind-protect + (while (and (not done) + (< (float-time) deadline)) + (accept-process-output (neat-connection-process conn) 0.05)) + (unless done + (remhash id (neat-connection-pending conn)))) + ;; Only reached when the wait ended by itself: a quit, or the + ;; throw `while-no-input' does for a completion UI, says nothing + ;; about the server. + (neat-client--note-tooling conn done)) + (nreverse responses))) + +(defun neat-client--request-async (conn timeout send callback) + "Send a request with SEND and call CALLBACK with CONN's responses. +SEND is as for `neat-client--request-sync'. CALLBACK gets the +responses in the order they came once `done' arrives, or whatever +came before TIMEOUT seconds ran out. Either way it counts toward +`neat-tooling-stalled-p', and a timeout unregisters the request, so +a late reply goes nowhere." + (let (responses finished timer id) + (setq id (funcall + send + (lambda (resp) + (push resp responses) + (when (and (not finished) + (member "done" (neat-bencode-get resp "status"))) + (setq finished t) + (when timer (cancel-timer timer)) + (neat-client--note-tooling conn t) + (funcall callback (nreverse responses)))))) + (unless finished + (setq timer (run-at-time + timeout nil + (lambda () + (unless finished + (setq finished t) + (remhash id (neat-connection-pending conn)) + (neat-client--note-tooling conn nil) + (funcall callback (nreverse responses))))))) + id)) + +(defun neat-client--ns-rejected-p (responses) + "Return non-nil if RESPONSES look like the server turned down their ns. +That's a `namespace-not-found' status, or a bare `error' with nothing +more specific next to it. Servers differ in what they do with a +namespace that isn't loaded yet, so a tooling request that named one +and got this back, with no results, is worth repeating without it. +An `unknown-op' or `unknown-session' comes with `error' as well, but +has nothing to do with the ns." + (cl-some (lambda (resp) + (let ((status (neat-bencode-get resp "status"))) + (or (member "namespace-not-found" status) + (and (member "error" status) + (cl-every (lambda (s) (member s '("error" "done"))) + status))))) + responses)) (defun neat-completions-sync (conn prefix &optional ns timeout) "Block until `completions' for PREFIX (in NS) come back from CONN. Return the list of candidate dicts (typically `(\"candidate\" . \"foo\") -`(\"type\" . \"function\")' shaped) or nil on timeout. -TIMEOUT defaults to 1 second." - (let (candidates done) - (neat-completions - conn prefix ns - (lambda (resp) - (let ((c (neat-bencode-get resp "completions"))) - (when c (setq candidates (append candidates c)))) - (when (member "done" (neat-bencode-get resp "status")) - (setq done t)))) - (neat-client--block-for-done conn (or timeout 1) (lambda () done)) - candidates)) +`(\"type\" . \"function\")' shaped), as many as arrived within +TIMEOUT seconds (default 1). If the server turns NS down +\(`namespace-not-found', or a bare `error'), the request goes out +again without it." + (let* ((responses (neat-client--request-sync + conn (or timeout 1) + (lambda (callback) + (neat-completions conn prefix ns callback)))) + (candidates (mapcan (lambda (resp) + (copy-sequence + (neat-bencode-get resp "completions"))) + responses))) + (if (and ns (not candidates) (neat-client--ns-rejected-p responses)) + (neat-completions-sync conn prefix nil timeout) + candidates))) (defun neat-lookup-sync (conn sym &optional ns timeout) "Block until CONN responds to a `lookup' for SYM (in NS). -Return the `info' dict, or nil if absent / on timeout. -TIMEOUT defaults to 1 second." - (let (info done) - (neat-lookup - conn sym ns - (lambda (resp) - (let ((i (neat-bencode-get resp "info"))) - (when i (setq info i))) - (when (member "done" (neat-bencode-get resp "status")) - (setq done t)))) - (neat-client--block-for-done conn (or timeout 1) (lambda () done)) - info)) +Return the `info' dict, or nil if none came within TIMEOUT seconds +\(default 1). If the server turns NS down (`namespace-not-found', or +a bare `error'), the request goes out again without it." + (let* ((responses (neat-client--request-sync + conn (or timeout 1) + (lambda (callback) (neat-lookup conn sym ns callback)))) + (info (cl-some (lambda (resp) (neat-bencode-get resp "info")) + responses))) + (if (and ns (not info) (neat-client--ns-rejected-p responses)) + (neat-lookup-sync conn sym nil timeout) + info))) + +(defun neat-lookup-async (conn sym ns timeout callback) + "Look SYM up on CONN (in NS) and call CALLBACK with the `info' dict. +CALLBACK gets nil when the server has none or doesn't answer within +TIMEOUT seconds; a timeout counts toward `neat-tooling-stalled-p'. +Like `neat-lookup-sync', this asks again without NS when the server +turns NS down." + (neat-client--request-async + conn timeout + (lambda (cb) (neat-lookup conn sym ns cb)) + (lambda (responses) + (let ((info (cl-some (lambda (r) (neat-bencode-get r "info")) + responses))) + (if (and ns (not info) (neat-client--ns-rejected-p responses) + (neat-connection-live-p conn)) + (neat-lookup-async conn sym nil timeout callback) + (funcall callback info)))))) + +(defun neat-close-session-sync (conn &optional session timeout) + "Close SESSION on CONN and block until the server confirms. +SESSION defaults to CONN's current one. Return non-nil if the server +confirmed within TIMEOUT seconds, which defaults to 1 second; a +connection that goes away first doesn't count." + (let ((status (neat-bencode-get + (car (last (neat-client--request-sync + conn (or timeout 1) + (lambda (callback) + (neat-close-session conn session callback))))) + "status"))) + (and (member "done" status) + (not (member "connection-closed" status)) + t))) ;;;; Process filter / sentinel @@ -491,8 +705,9 @@ bencode messages as it can." Malformed bencode signals `neat-bencode-error', which would otherwise propagate up out of the process filter and silently kill the cycle. We catch it here, log the offending bytes via the message log, and -clear the recv buffer -- the protocol state is unrecoverable past -the bad message, but at least the filter survives. As elsewhere, +disconnect. Past a bad byte there's no telling where the next +message starts, so reading on would only misparse whatever follows; +disconnecting at least flushes every pending callback. As elsewhere, `debug-on-error' steps the guard aside so the bug is visible during interactive debugging." (condition-case-unless-debug err @@ -510,41 +725,71 @@ interactive debugging." (neat-connection-recv-buffer conn) err)) (setf (neat-connection-recv-buffer conn) (unibyte-string)) - (message "neat: dropped malformed bencode from %s:%s (%S)" + (message "neat: malformed bencode from %s:%s, disconnecting (%S)" (neat-connection-host conn) (neat-connection-port conn) - err)))) + err) + (neat-disconnect conn)))) (defun neat-client--dispatch (conn message) "Look up MESSAGE's callback in CONN and invoke it. -When the response's status contains `done' the callback entry is -pruned afterwards." +A server can send any bencode value, so MESSAGE gets checked first: +anything other than a dict is logged and skipped, a `status' sent as +a plain string counts as a list of one, and any other `status' that +isn't a list is dropped as if it weren't there. Either would +otherwise blow up in here or in the callback. An `unknown-session' +reply gets a `done' added if it lacks one, since nothing more can +come for a request the server has no session for. A message without +a callback goes to `neat-unhandled-message-functions'. When the +response's status contains `done' the callback entry is pruned +before the callback runs." (neat-client--log conn :in message) - (let* ((id (neat-bencode-get message "id")) - (status (neat-bencode-get message "status")) - (callback (and id (gethash id (neat-connection-pending conn))))) - (when callback - ;; Don't let a buggy callback nuke the whole filter. Skip the - ;; trap when the user is debugging, so `toggle-debug-on-error' - ;; reveals the underlying problem instead of swallowing it. - (condition-case-unless-debug err - (funcall callback message) - (error (message "neat: callback error: %S" err)))) - (when (and id (member "done" status)) - (remhash id (neat-connection-pending conn))))) + (if (not (neat-bencode-dict-p message)) + (neat-client--log conn :note '(skipped "not a dict")) + (let ((status (neat-bencode-get message "status"))) + (when (stringp status) + (setq status (list status)) + (setf (alist-get "status" message nil nil #'equal) status)) + (cond + ((not (listp status)) + (setq message (cl-remove "status" message :key #'car :test #'equal))) + ((and (member "unknown-session" status) + (not (member "done" status))) + (setf (alist-get "status" message nil nil #'equal) + (append status '("done")))))) + (let* ((id (neat-bencode-get message "id")) + (status (neat-bencode-get message "status")) + (callback (and id (gethash id (neat-connection-pending conn))))) + ;; Prune before the callback runs: one that gets quit out of + ;; (C-g at a prompt it opened) must not leave its request behind. + (when (and id (member "done" status)) + (remhash id (neat-connection-pending conn)) + (setf (neat-connection-evals conn) + (delete id (neat-connection-evals conn))) + (unless (neat-connection-evals conn) + (setf (neat-connection-stalled conn) nil))) + (if callback + ;; Don't let a buggy callback nuke the whole filter. Skip the + ;; trap when the user is debugging, so `toggle-debug-on-error' + ;; reveals the underlying problem instead of swallowing it. + (condition-case-unless-debug err + (funcall callback message) + (error (message "neat: callback error: %S" err))) + (with-demoted-errors "neat: unhandled message hook: %S" + (run-hook-with-args 'neat-unhandled-message-functions + conn message)))))) (defun neat-client--sentinel (proc _event) "Sentinel for nREPL connection PROC. Delegates to `neat-client--cleanup'." (unless (process-live-p proc) (when-let* ((conn (process-get proc 'neat-connection))) - (neat-client--cleanup conn "connection closed")))) + (neat-client--cleanup conn)))) -(defun neat-client--cleanup (conn reason) +(defun neat-client--cleanup (conn) "Single cleanup path for a dead CONN. Drops CONN from `neat-connections', demotes the default if needed, -flushes pending callbacks with REASON, and runs -`neat-disconnect-functions'. +flushes pending callbacks, and runs `neat-disconnect-functions'. Idempotent: the registry-membership check makes subsequent calls on the same connection no-ops, so `neat-disconnect' (synchronous) @@ -556,26 +801,29 @@ updates buffers built on top." (setq neat-connections (delq conn neat-connections)) (when (eq neat-default-connection conn) (setq neat-default-connection (car neat-connections))) - (neat-client--flush-pending conn reason) + (neat-client--flush-pending conn) (with-demoted-errors "neat: disconnect hook: %S" (run-hook-with-args 'neat-disconnect-functions conn)))) -(defun neat-client--flush-pending (conn reason) +(defun neat-client--flush-pending (conn) "Notify every pending callback on CONN that the connection is gone. -Each callback gets a synthesized response with a `done'/`interrupted' -status and an `err' field describing REASON." +Each callback gets a synthesized response whose status is +\(\"done\" \"connection-closed\"), as documented in `neat-send'. +It deliberately carries no `err' text: the caller decides how (and +whether) to tell the user." (let ((pending (neat-connection-pending conn))) (maphash (lambda (id callback) (condition-case-unless-debug _ (funcall callback `(("id" . ,id) - ("status" . ("done" "interrupted")) - ("err" . ,(format "neat: %s" reason)))) + ("status" . ("done" "connection-closed")))) (error nil))) pending) - (clrhash pending))) + (clrhash pending) + (setf (neat-connection-evals conn) nil + (neat-connection-stalled conn) nil))) (provide 'neat-client) ;;; neat-client.el ends here diff --git a/neat-repl.el b/neat-repl.el index 9765d66..afb0b7e 100644 --- a/neat-repl.el +++ b/neat-repl.el @@ -83,6 +83,12 @@ in a language with very different bracketing rules.") (defvar-local neat-repl--current-ns nil "Most-recent namespace reported by the server for this buffer.") +(defvar-local neat-repl--prompt-start nil + "Marker at the start of the prompt waiting for input, or nil. +Set whenever a prompt goes in and cleared once input is sent, so +output that turns up between evals can be put above the prompt +instead of after it.") + (defvar-local neat-repl--connection-dead nil "Non-nil once the buffer's connection has died. Set by `neat-repl--handle-disconnect'. The input sender consults this @@ -173,11 +179,123 @@ purpose is to satisfy `comint-output-filter' and friends." (or neat-repl--current-ns neat-repl-default-ns))) (defun neat-repl--insert-prompt () - "Insert a fresh prompt at the end of the buffer." + "Insert a fresh prompt at the end of the buffer. +It starts on a line of its own, even after output that didn't end one +or after the dead prompt of an earlier connection in a reused buffer. +Does nothing while a prompt is already waiting for input, so two +requests finishing back to back don't leave two prompts behind." (let ((proc (get-buffer-process (current-buffer)))) - (when proc + (when (and proc (not neat-repl--prompt-start)) + (unless (save-excursion (goto-char (process-mark proc)) (bolp)) + (comint-output-filter proc "\n")) + (setq neat-repl--prompt-start (copy-marker (process-mark proc))) + (comint-output-filter proc (neat-repl--prompt))))) + +(defun neat-repl--redraw-prompt () + "Bring a waiting prompt up to date with `neat-repl--current-ns'. +A source-buffer eval can move the session to another namespace while +the prompt sits there showing the old one. Anything typed after the +prompt stays as it is." + (let ((proc (get-buffer-process (current-buffer)))) + (when (and proc neat-repl--prompt-start + (marker-position neat-repl--prompt-start)) + (let ((inhibit-read-only t)) + (save-restriction + (widen) + (delete-region neat-repl--prompt-start (process-mark proc)))) (comint-output-filter proc (neat-repl--prompt))))) +(defun neat-repl--emit-output (text face) + "Insert TEXT in FACE above the prompt waiting for input. +With no prompt showing (an eval from this buffer is still running) +TEXT just streams in at the process mark like any other output. +Either way it goes through `comint-output-filter'. A chunk that +doesn't end in a newline gets one, so the prompt stays on its own +line; the next chunk picks up where that one left off." + (let ((proc (get-buffer-process (current-buffer)))) + (cond + ((not proc) nil) + ((and neat-repl--prompt-start (marker-position neat-repl--prompt-start)) + (neat-repl--insert-above-prompt proc text face)) + (t (comint-output-filter proc (propertize text 'face face)))))) + +(defvar ansi-color-context-region) + +(defvar-local neat-repl--ansi-context nil + "ANSI color state for text inserted above the prompt. +It plays the part of `ansi-color-context-region' for that text alone. +The context streamed output uses points past the prompt, so sharing +one would let a color left on at either end trip up the other.") + +(defun neat-repl--insert-above-prompt (proc text face) + "Insert TEXT in FACE right above the waiting prompt in PROC's buffer. +The text goes through `comint-output-filter' itself, with the process +mark moved to the start of the prompt for the duration, so it gets +what any other output gets: filters, ANSI colors, carriage motion. +A marker that moves along with insertions keeps track of the prompt, +and the process mark and comint's record of where the prompt is are +put back afterwards. ANSI colors keep their own state here (see +`neat-repl--ansi-context'), a chunk ending in a carriage return gets +its line overwritten by the next one, as comint does for streamed +output, and `comint-move-point-for-output' moves point to the input +rather than onto the prompt." + (unless (string-empty-p text) + (let* ((pmark (process-mark proc)) + (end (copy-marker (process-mark proc))) + (prompt (copy-marker neat-repl--prompt-start t)) + (streamed-ansi (and (boundp 'ansi-color-context-region) + ansi-color-context-region)) + (overwrite (string-suffix-p "\r" text)) + (text (if overwrite (string-trim-right text "\r+") text)) + (padded (not (string-suffix-p "\n" text)))) + (save-restriction + (widen) + (unwind-protect + (progn + (when (and (> prompt (point-min)) + (get-text-property (1- prompt) 'neat-repl-padding)) + (let ((inhibit-read-only t)) + (delete-region (1- prompt) prompt))) + (set-marker pmark prompt) + ;; A color still on from the last chunk carries on here. + (when-let* ((marker (cadr neat-repl--ansi-context)) + ((markerp marker)) + ((marker-position marker))) + (set-marker marker prompt)) + (setq-local ansi-color-context-region neat-repl--ansi-context) + ;; comint takes the last line of what it inserts for a + ;; prompt unless it ends in a newline, and with the + ;; process mark at the prompt it would move point there. + (let ((comint-move-point-for-output nil)) + (comint-output-filter + proc (propertize (if padded + (concat text (propertize + "\n" 'neat-repl-padding t)) + text) + 'face face))) + (when (and overwrite padded) + (let ((eol (1- prompt)) + (inhibit-field-text-motion t)) + (with-silent-modifications + (put-text-property (save-excursion + (goto-char eol) + (line-beginning-position)) + eol 'comint-must-overwrite t))))) + (setq neat-repl--ansi-context ansi-color-context-region) + (setq-local ansi-color-context-region streamed-ansi) + (set-marker pmark end) + (set-marker neat-repl--prompt-start prompt) + (setq comint-last-prompt + (cons (copy-marker prompt) (copy-marker end))) + (let ((inhibit-read-only t)) + (font-lock-append-text-property prompt end 'font-lock-face + 'comint-highlight-prompt)) + (set-marker prompt nil) + (set-marker end nil))) + (when comint-move-point-for-output + (dolist (window (get-buffer-window-list nil nil t)) + (comint-adjust-window-point window proc)))))) + (defun neat-repl--input-complete-p (input) "Return non-nil if INPUT is a balanced, complete form. @@ -208,6 +326,7 @@ Otherwise insert a newline so the user can keep typing the form." (let* ((buffer (current-buffer)) (conn neat-current-connection) (trimmed (string-trim-right (substring-no-properties input)))) + (setq neat-repl--prompt-start nil) (cond ((or neat-repl--connection-dead (and conn (not (neat-connection-live-p conn)))) @@ -217,12 +336,13 @@ Otherwise insert a newline so the user can keep typing the form." ((string-empty-p trimmed) (neat-repl--insert-prompt)) (t - (neat-eval - conn trimmed - :callback (lambda (resp) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (neat-repl--render-response resp))))))))) + (let ((request (neat-repl--request-create :from-repl t))) + (neat-eval + conn trimmed + :callback (lambda (resp) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (neat-repl--render-response resp request)))))))))) (defun neat-repl--handle-disconnect (conn) "Mark CONN's REPL buffer as closed, if it has one. @@ -233,64 +353,231 @@ on the same dead connection are no-ops." (with-current-buffer buf (unless neat-repl--connection-dead (setq neat-repl--connection-dead t) - (let ((proc (get-buffer-process (current-buffer)))) - (when (process-live-p proc) - (comint-output-filter - proc (propertize ";; connection closed\n" - 'face 'neat-repl-error)))))))) + (when (process-live-p (get-buffer-process (current-buffer))) + (neat-repl--emit-output ";; connection closed\n" + 'neat-repl-error)))))) -;;;###autoload +;; Not autoloaded, for the same reason as the hook below. (add-hook 'neat-disconnect-functions #'neat-repl--handle-disconnect) -(defun neat-repl--render-response (resp) - "Insert the user-visible parts of nREPL response RESP into the buffer." - (let ((proc (get-buffer-process (current-buffer))) - (value (neat-bencode-get resp "value")) - (out (neat-bencode-get resp "out")) - (err (neat-bencode-get resp "err")) - (ex (neat-bencode-get resp "ex")) - (ns (neat-bencode-get resp "ns")) - (status (neat-bencode-get resp "status"))) +(cl-defstruct (neat-repl--request (:constructor neat-repl--request-create) + (:copier nil)) + "Rendering state for one request whose responses land in a REPL buffer. +FROM-REPL is non-nil when the request is input typed into the REPL; +only those get a fresh prompt at `done'. + +NS is the namespace the request named explicitly, if any. The prompt +follows the `ns' a reply reports only when NS is nil. A request that +names its own `ns' gets it bound for that one eval and then dropped, +so following it would leave the prompt showing a namespace the REPL +isn't in. Without one the eval runs in the session's namespace, and +an `(ns ...)' or `(in-ns ...)' in it really does move the session, +whether it was typed into the REPL or sent from a source buffer. + +SAW-ERR is set once the request has printed anything on `err'. EX +holds the last `ex' it reported, held back until `done' and dropped +if `err' had something to say: Basilisp and jank put the whole +traceback in both fields, and nREPL's `ex' is only the exception +class, so `err' is the better of the two whenever there is one." + from-repl ns saw-err ex) + +(defun neat-repl--request-update (request resp) + "Note RESP's `err' and `ex' on REQUEST and return what's due now. +The result is (EX . PROBLEM). EX is an `ex' to show now: at `done', +when nothing came on `err'. PROBLEM is the error status line from +`neat-response-error', leaving out a bare `error' that an earlier +`err' or `ex' already explained." + (when (neat-bencode-get resp "err") + (setf (neat-repl--request-saw-err request) t)) + (when-let* ((ex (neat-bencode-get resp "ex"))) + (setf (neat-repl--request-ex request) ex)) + (let ((saw-err (neat-repl--request-saw-err request)) + (ex (neat-repl--request-ex request))) + (cons (and (member "done" (neat-bencode-get resp "status")) + (not saw-err) + ex) + (neat-response-error resp (or saw-err ex))))) + +(defun neat-repl--render-response (resp &optional request) + "Insert the user-visible parts of nREPL response RESP into the buffer. +REQUEST is the `neat-repl--request' RESP answers; pass the same one +for every response to a request. Without it RESP is rendered on its +own, and an `ex' only shows up if `done' comes in the same message. + +Output goes above the prompt when one is waiting for input, which is +where results of source-buffer evals land; only input typed into the +REPL gets a fresh prompt at `done'." + (let* ((request (or request (neat-repl--request-create))) + (proc (get-buffer-process (current-buffer))) + (value (neat-bencode-get resp "value")) + (out (neat-bencode-get resp "out")) + (err (neat-bencode-get resp "err")) + (ns (neat-bencode-get resp "ns")) + (status (neat-bencode-get resp "status")) + (due (neat-repl--request-update request resp))) ;; Track the namespace as soon as we see one so the next prompt - ;; reflects any `(in-ns ...)' or namespace-switching form. - (when ns - (setq neat-repl--current-ns ns)) + ;; reflects any `(in-ns ...)' or namespace-switching form. A + ;; `namespace-not-found' reply names the namespace that isn't there. + (when (and ns (not (neat-repl--request-ns request)) + (not (member "namespace-not-found" status))) + (unless (equal ns neat-repl--current-ns) + (setq neat-repl--current-ns ns) + (neat-repl--redraw-prompt)) + (when neat-current-connection + (setf (neat-connection-ns neat-current-connection) ns))) (when proc (when out - (comint-output-filter - proc (propertize out 'face 'neat-repl-output))) + (neat-repl--emit-output out 'neat-repl-output)) (when err - (comint-output-filter - proc (propertize err 'face 'neat-repl-error))) + (neat-repl--emit-output err 'neat-repl-error)) (when value - (comint-output-filter - proc (concat (propertize value 'face 'neat-repl-value) "\n"))) - (when ex - (comint-output-filter - proc (propertize (format "%s\n" ex) 'face 'neat-repl-error))) - (when (and (member "need-input" status) - neat-current-connection - (neat-connection-live-p neat-current-connection)) - (neat-repl--handle-need-input neat-current-connection)) - (when (member "done" status) - (comint-output-filter proc (neat-repl--prompt)))))) - -(defun neat-repl--handle-need-input (conn) + (neat-repl--emit-output (concat value "\n") 'neat-repl-value)) + (when (car due) + (neat-repl--emit-output (format "%s\n" (car due)) 'neat-repl-error)) + (when (cdr due) + (neat-repl--emit-output (format ";; %s\n" (cdr due)) 'neat-repl-error)) + (when neat-current-connection + (neat-repl--answer-status neat-current-connection resp)) + ;; A dead connection gets its own marker from + ;; `neat-repl--handle-disconnect'; a prompt would only invite + ;; input that has nowhere to go. + (when (and (member "done" status) + (not (member "connection-closed" status)) + (neat-repl--request-from-repl request)) + (neat-repl--insert-prompt))))) + +(defun neat-repl--answer-status (conn resp) + "Deal with the statuses in RESP from CONN that need the user. +A `need-input' gets answered from the minibuffer and an +`unknown-session' brings up the offer of a new session. Shared by +the REPL and by source-buffer evals with no REPL buffer to go to." + (let ((status (neat-bencode-get resp "status"))) + (when (and (member "need-input" status) + (neat-connection-live-p conn)) + (neat-repl--handle-need-input conn resp)) + (when (member "unknown-session" status) + (neat-repl--offer-new-session conn resp)))) + +(defun neat-repl--offer-new-session (conn resp) + "Offer to clone a fresh session after CONN's server disowned one. +RESP is the `unknown-session' reply. When it's about CONN's current +session that session is dropped from CONN, so later requests stop +sending it, and the user gets asked whether to clone a new one. +Declining leaves CONN without a session, which nREPL answers with a +throwaway session for every request. Either way the namespace the +old session was in is forgotten too, by CONN and by its REPL, since +whatever comes next starts out somewhere else." + (let ((session (neat-bencode-get resp "session")) + (current (neat-connection-session conn))) + (when (and current + (or (null session) (equal session current)) + (neat-connection-live-p conn)) + (setf (neat-connection-session conn) nil + (neat-connection-ns conn) nil) + (when-let* ((buf (neat-repl-buffer-for conn)) + ((buffer-live-p buf))) + (with-current-buffer buf + (setq neat-repl--current-ns nil))) + ;; C-g here means no, not a quit out of the process filter. + (when (condition-case nil + (let ((enable-recursive-minibuffers t)) + (y-or-n-p + "Neat: the server lost this session; clone a new one? ")) + (quit nil)) + (neat-clone-session conn))))) + +(defun neat-repl--handle-unhandled-message (conn message) + "Show `out' and `err' from MESSAGE above the prompt in CONN's REPL. +Run from `neat-unhandled-message-functions', so MESSAGE belongs to no +pending request: output with no `id', or late output from an eval +that already finished." + (when-let* ((buf (neat-repl-buffer-for conn)) + ((buffer-live-p buf))) + (let ((out (neat-bencode-get message "out")) + (err (neat-bencode-get message "err"))) + (when (or out err) + (with-current-buffer buf + (when out (neat-repl--emit-output out 'neat-repl-output)) + (when err (neat-repl--emit-output err 'neat-repl-error))))))) + +;; Not autoloaded: the handler only exists once this file is loaded, +;; and a client used without the REPL has no buffer to show output in. +(add-hook 'neat-unhandled-message-functions + #'neat-repl--handle-unhandled-message) + +(defvar neat-repl-stdin-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map (kbd "C-c C-d") #'neat-repl-stdin-eof) + map) + "Keymap for the minibuffer prompt that answers a `need-input'.") + +(defvar neat-repl--stdin-eof nil + "Non-nil once the `stdin' prompt has been answered with end-of-file.") + +(defun neat-repl-stdin-eof () + "Answer the pending `stdin' prompt with end-of-file instead of a line." + (interactive) + (setq neat-repl--stdin-eof t) + (exit-minibuffer)) + +(defun neat-repl--handle-need-input (conn resp) "Prompt the user for a line of input and ship it to CONN via the `stdin' op. Server-side reads (`read-line', `input', ...) trigger a `need-input' -status response that pauses the eval until the client replies with a -`stdin' op. A trailing newline is appended so `read-line'-style readers -finish. `C-g' at the prompt interrupts the eval instead." - (condition-case nil - (let ((input (read-string "stdin: "))) - (neat-stdin conn (concat input "\n"))) - (quit (neat-interrupt conn)))) +status response RESP that pauses the eval until the client replies +with a `stdin' op. The reply goes to RESP's session, which needn't +be CONN's current one. A trailing newline is appended so +`read-line'-style readers finish. + +\\\\[neat-repl-stdin-eof] at the prompt sends \ +end-of-file (an empty `stdin') instead. +`C-g' interrupts the eval, or sends end-of-file when the server can't +interrupt, so the eval doesn't sit waiting forever. The prompt opens +even when the minibuffer is already in use, since `need-input' can +turn up at any moment." + (let ((session (neat-bencode-get resp "session")) + (neat-repl--stdin-eof nil) + (enable-recursive-minibuffers t)) + (condition-case nil + (let ((input (read-from-minibuffer + (substitute-command-keys + (concat "stdin (\\" + "\\[neat-repl-stdin-eof] for EOF): ")) + nil neat-repl-stdin-map))) + (neat-stdin conn (if neat-repl--stdin-eof "" (concat input "\n")) + :session session)) + (quit (if (neat-op-supported-p conn "interrupt") + (neat-repl--interrupt conn session (neat-bencode-get resp "id")) + (neat-stdin conn "" :session session)))))) + +(defun neat-repl--interrupt (conn &optional session interrupt-id) + "Ask CONN's server to interrupt the eval it's running. +SESSION and INTERRUPT-ID go to `neat-interrupt'. Signals a +`user-error' up front when the server doesn't advertise `interrupt', +and reports any reply that says the interrupt didn't happen. Without +that the user would just see nothing happen." + (unless (neat-op-supported-p conn "interrupt") + (user-error "Neat: the server doesn't support interrupt")) + (neat-interrupt + conn session interrupt-id + (lambda (resp) + (let ((status (neat-bencode-get resp "status"))) + (cond ((member "unknown-op" status) + (message "Neat: the server doesn't support interrupt")) + ((member "session-idle" status) + (message "Neat: nothing to interrupt")) + ((member "session-ephemeral" status) + (message "Neat: can't interrupt an eval with no session")) + ((member "interrupt-id-mismatch" status) + (message "Neat: that eval isn't the one running")) + ((member "error" status) + (message "Neat: the interrupt failed"))))))) (defun neat-repl-interrupt () "Send an `interrupt' op to the REPL's connection." (interactive) (if neat-current-connection - (neat-interrupt neat-current-connection) + (neat-repl--interrupt neat-current-connection) (user-error "Neat: no connection in this buffer"))) (defun neat-repl-clear-buffer () @@ -300,13 +587,30 @@ underlying connection." (interactive) (let ((inhibit-read-only t)) (erase-buffer) + (setq neat-repl--prompt-start nil) (neat-repl--insert-prompt))) +(defun neat-repl--close-connection (conn &optional no-wait) + "Close CONN's session on the server, then disconnect CONN. +Without the `close' the session would outlive the REPL on the server. +Unless NO-WAIT is non-nil we wait briefly for the server to confirm, +so its reply doesn't run into a socket that's already gone. Cutting +the wait short with \\[keyboard-quit] still disconnects." + (unwind-protect + (when (and (neat-connection-live-p conn) + (neat-connection-session conn) + (neat-op-supported-p conn "close")) + (ignore-errors + (if no-wait + (neat-close-session conn) + (neat-close-session-sync conn)))) + (neat-disconnect conn))) + (defun neat-repl-quit () - "Disconnect from the nREPL server and bury this buffer." + "Close the REPL's session, disconnect, and bury this buffer." (interactive) (when neat-current-connection - (neat-disconnect neat-current-connection) + (neat-repl--close-connection neat-current-connection) (setq neat-current-connection nil)) (let ((proc (get-buffer-process (current-buffer)))) (when (process-live-p proc) @@ -314,12 +618,15 @@ underlying connection." (bury-buffer)) (defun neat-repl--kill-buffer-cleanup () - "Tear down the connection, persist history, and stop the pipe process." + "Persist history, close the session, disconnect, and stop the pipe process. +The `close' goes out without waiting for the reply: a kill shouldn't +stall on a busy or wedged server." (when comint-input-ring-file-name (ignore-errors (comint-write-input-ring))) (when (and neat-current-connection (neat-connection-live-p neat-current-connection)) - (ignore-errors (neat-disconnect neat-current-connection))) + (ignore-errors + (neat-repl--close-connection neat-current-connection 'no-wait))) (let ((proc (get-buffer-process (current-buffer)))) (when (process-live-p proc) (delete-process proc)))) diff --git a/neat.el b/neat.el index 41b522f..f18e70b 100644 --- a/neat.el +++ b/neat.el @@ -162,7 +162,8 @@ disconnects it, \\[neat-connections-refresh] reloads from (when (derived-mode-p 'neat-connections-mode) (neat-connections-refresh))))) -;;;###autoload +;; Not autoloaded: the function only exists once this file is loaded, +;; and the buffer it refreshes can't exist before that either. (add-hook 'neat-disconnect-functions #'neat--connections-buffer-refresh) ;;;###autoload @@ -234,8 +235,10 @@ with `neat-mode' enabled will use it automatically." (neat-clone-session conn (lambda (resp) - (when (member "done" (neat-bencode-get resp "status")) - (when (buffer-live-p buffer) + (let ((status (neat-bencode-get resp "status"))) + (when (and (member "done" status) + (not (member "connection-closed" status)) + (buffer-live-p buffer)) (with-current-buffer buffer (neat-repl--insert-prompt)))))) (pop-to-buffer buffer) @@ -259,7 +262,7 @@ explicitly via `neat-set-ns', in a major-mode hook, or via The default returns `neat-ns'. Replace with a parser that reads the buffer for languages where the namespace is declared in source (for example, a `(ns foo.bar)' form in Clojure). Whatever is returned -becomes the `ns' field on the `eval' op.") +becomes the `ns' field on the `eval', `completions' and `lookup' ops.") (defun neat-set-ns (ns) "Set the buffer-local namespace `neat-ns' to NS for subsequent evaluations. @@ -270,21 +273,43 @@ Empty input clears the override." (setq neat-ns (if (string-empty-p ns) nil ns)) (message "Neat: ns is %s" (or neat-ns "(unset)"))) +(defun neat--tooling-ns (conn) + "Return the ns to send with `completions' and `lookup' on CONN, or nil. +That's whatever `neat-buffer-ns-function' says, falling back to the +namespace CONN's REPL last reported. Some servers won't answer +either op without an ns, while others may not take one they haven't +loaded yet, so a request whose ns gets turned down is sent again +without it." + (or (funcall neat-buffer-ns-function) + (neat-connection-ns conn))) + (defun neat--require-connection () "Return the active connection, or signal a user-error." (or (neat-active-connection) (user-error "Neat: no active connection; M-x neat to start one"))) -(defun neat--render-into-repl (conn resp) - "If CONN has a REPL buffer, render RESP there; otherwise message a brief result." - (let ((repl (neat-repl-buffer-for conn))) - (if (buffer-live-p repl) - (with-current-buffer repl - (neat-repl--render-response resp)) - (let ((value (neat-bencode-get resp "value")) - (err (neat-bencode-get resp "err"))) - (cond (err (message "neat: %s" (string-trim err))) - (value (message "=> %s" value))))))) +(defun neat--eval-callback (conn &optional ns) + "Return a callback that renders one request's responses from CONN. +Each response is rendered in CONN's REPL buffer if it has one; +otherwise a brief result is messaged. NS is the namespace the +request named, if any (see `neat-repl--request')." + (let ((request (neat-repl--request-create :ns ns))) + (lambda (resp) + (let ((repl (neat-repl-buffer-for conn))) + (if (buffer-live-p repl) + (with-current-buffer repl + (neat-repl--render-response resp request)) + (let ((value (neat-bencode-get resp "value")) + (err (neat-bencode-get resp "err")) + (status (neat-bencode-get resp "status")) + (due (neat-repl--request-update request resp))) + (cond (err (message "neat: %s" (string-trim err))) + (value (message "=> %s" value)) + ((car due) (message "neat: %s" (string-trim (car due)))) + ((cdr due) (message "neat: %s" (cdr due))) + ((member "connection-closed" status) + (message "neat: connection closed"))) + (neat-repl--answer-status conn resp))))))) (defun neat--eval-string (code &optional pos) "Evaluate CODE on the active connection. @@ -306,7 +331,7 @@ namespace is whatever `neat-buffer-ns-function' returns." (ns (funcall neat-buffer-ns-function))) (neat-eval conn code :file file :line line :column column :ns ns - :callback (lambda (resp) (neat--render-into-repl conn resp))))) + :callback (neat--eval-callback conn ns)))) (defun neat-eval-last-sexp () "Evaluate the sexp before point." @@ -360,7 +385,7 @@ not necessarily resolvable on the server side." conn contents :file-path buffer-file-name :file-name (file-name-nondirectory buffer-file-name) - :callback (lambda (resp) (neat--render-into-repl conn resp))))) + :callback (neat--eval-callback conn)))) (defun neat-switch-to-repl () "Pop to the REPL buffer for the active connection." @@ -374,15 +399,23 @@ not necessarily resolvable on the server side." (defun neat-interrupt-eval () "Interrupt the in-flight eval on the active connection." (interactive) - (neat-interrupt (neat--require-connection))) + (neat-repl--interrupt (neat--require-connection))) ;;;; Completion-at-point and eldoc ;; These rely on the standard `completions' and `lookup' nREPL ops. -;; Servers that don't implement them surface as `unknown-op' status -;; responses, the sync helpers return nil, and we quietly defer to -;; other backends. +;; When the server's `describe' reply doesn't list the op we need, +;; CAPF, eldoc and xref quietly step aside for other backends. A +;; server whose `describe' lists no ops at all gets the benefit of the +;; doubt: the request goes out, comes back `unknown-op' if the op isn't +;; there, the sync helpers return nil, and we end up in the same place. +;; +;; Completion and eldoc also hold off while `neat-tooling-stalled-p' +;; says requests would only queue up behind a running eval, and eldoc +;; keeps to one lookup in flight per connection. Otherwise every +;; completion attempt would sit out its full timeout, and eldoc +;; lookups would pile up and all answer long after point moved on. (defcustom neat-completion-timeout 1.0 "Seconds to wait for a `completions' response before giving up." @@ -432,13 +465,17 @@ which is the just-locked buffer." (defun neat-show-doc-at-point () "Pop a `*neat-doc*' help buffer with the docstring for the symbol at point. -Uses the `lookup' op. Signals a `user-error' if there's no symbol at -point or the server doesn't know about the symbol." +Uses the `lookup' op. Signals a `user-error' if the server doesn't +support `lookup', there's no symbol at point, or the server doesn't +know about the symbol." (interactive) (let* ((conn (neat--require-connection)) + (_ (unless (neat-op-supported-p conn "lookup") + (user-error "Neat: the server doesn't support lookup"))) (sym (or (thing-at-point 'symbol t) (user-error "Neat: no symbol at point"))) - (info (neat-lookup-sync conn sym nil neat-lookup-timeout))) + (info (neat-lookup-sync conn sym (neat--tooling-ns conn) + neat-lookup-timeout))) (unless info (user-error "Neat: no doc for `%s'" sym)) (neat--render-doc info))) @@ -469,11 +506,13 @@ surfaced via `:annotation-function' in the completion UI." (end (cdr bounds)) (prefix (buffer-substring-no-properties start end))) (when (and conn (neat-connection-live-p conn) - (>= (length prefix) 1)) + (neat-op-supported-p conn "completions") + (>= (length prefix) 1) + (not (neat-tooling-stalled-p conn))) (let ((cands (delq nil (mapcar #'neat--candidate-with-type (neat-completions-sync - conn prefix nil + conn prefix (neat--tooling-ns conn) neat-completion-timeout))))) (when cands (list start end cands @@ -607,25 +646,48 @@ Produces the eldoc display string from a `lookup' INFO dict. The default understands Clojure/Lisp-shape arglists `[a b & rest]'; override for servers that report arglists in a different syntax.") +(defvar neat--eldoc-in-flight (make-hash-table :test 'eq :weakness 'key) + "Connections with an eldoc lookup still waiting for its answer. +Only one goes out at a time per connection, so lookups can't pile up +behind a server that's busy with something else.") + (defun neat-eldoc-function (callback &rest _ignored) "Eldoc backend driven by the `lookup' op. Conforms to `eldoc-documentation-functions': fires the supplied -CALLBACK with the docstring once the server responds, so the UI -never blocks waiting on a lookup. When the user has moved point -by the time the response arrives, eldoc may briefly show stale -output -- acceptable trade-off for not blocking the editor." +CALLBACK with the docstring once the server responds, or with nil +when there's none, so the UI never blocks waiting on a lookup. When +the user has moved point by the time the response arrives, eldoc may +briefly show stale output, an acceptable trade-off for not blocking +the editor." (let ((conn (neat-active-connection)) (sym (neat--eldoc-thing-at-point)) (arg-index (funcall neat-eldoc-arg-index-function))) - (when (and conn sym (neat-connection-live-p conn)) - (neat-lookup - conn sym nil - (lambda (resp) - (when-let* ((info (neat-bencode-get resp "info")) - (str (funcall neat-eldoc-arglist-formatter - info arg-index))) - (funcall callback str :thing sym)))) + (when (and conn sym (neat-connection-live-p conn) + (neat-op-supported-p conn "lookup") + (not (gethash conn neat--eldoc-in-flight)) + (not (neat-tooling-stalled-p conn))) + (let ((ns (neat--tooling-ns conn)) + (sent nil)) + (puthash conn t neat--eldoc-in-flight) + (unwind-protect + (progn + (neat-lookup-async + conn sym ns neat-lookup-timeout + (lambda (info) + (remhash conn neat--eldoc-in-flight) + (let ((str (and info (funcall neat-eldoc-arglist-formatter + info arg-index)))) + ;; A nil tells eldoc there's nothing to wait for, so + ;; other backends' docs can go up. + (if str + (funcall callback str :thing sym) + (funcall callback nil))))) + (setq sent t)) + ;; If the lookup never went out, no answer will come to + ;; clear the flag. + (unless sent + (remhash conn neat--eldoc-in-flight)))) ;; Tell eldoc we'll call the callback asynchronously. t))) @@ -671,10 +733,13 @@ nREPL reports columns 1-indexed; `xref-file-location' wants them (defun neat--xref-backend () "`xref-backend-functions' entry for `neat-mode'. -Returns the `neat' backend symbol when a live connection is available -in the current buffer, otherwise nil so the next backend gets a turn." +Returns the `neat' backend symbol when a live connection whose server +supports `lookup' is available in the current buffer, otherwise nil so +the next backend gets a turn." (when-let* ((conn (neat-active-connection))) - (and (neat-connection-live-p conn) 'neat))) + (and (neat-connection-live-p conn) + (neat-op-supported-p conn "lookup") + 'neat))) (cl-defmethod xref-backend-identifier-at-point ((_backend (eql neat))) "Return the symbol around point as the xref identifier." @@ -683,7 +748,8 @@ in the current buffer, otherwise nil so the next backend gets a turn." (cl-defmethod xref-backend-definitions ((_backend (eql neat)) identifier) "Resolve IDENTIFIER to its definition via the `lookup' op." (when-let* ((conn (neat-active-connection)) - (info (neat-lookup-sync conn identifier nil + (info (neat-lookup-sync conn identifier + (neat--tooling-ns conn) neat-lookup-timeout)) (location (neat--xref-location-from-info info))) (list (xref-make identifier location)))) diff --git a/test/neat-bencode-test.el b/test/neat-bencode-test.el index 7f1399b..f77f624 100644 --- a/test/neat-bencode-test.el +++ b/test/neat-bencode-test.el @@ -36,8 +36,25 @@ ;; "héllo" is 5 chars but 6 bytes when UTF-8 encoded (expect encoded :to-equal (neat-bencode-test--bytes "6:héllo")))) - (it "encodes the empty list" - (expect (neat-bencode-encode '()) :to-equal "le")) + (it "encodes an empty vector as the empty list" + (expect (neat-bencode-encode []) :to-equal "le")) + + (it "encodes a vector as a list" + (expect (neat-bencode-encode [1 "spam"]) :to-equal "li1e4:spame")) + + (it "encodes a vector of string-headed lists as a list, not a dict" + (expect (neat-bencode-encode [("a" "b") ("c" "d")]) + :to-equal "ll1:a1:bel1:c1:dee")) + + (it "rejects nil at the top level" + (expect (neat-bencode-encode nil) :to-throw 'neat-bencode-error)) + + (it "rejects a nil dict value" + (expect (neat-bencode-encode '((op . "eval") (ns . nil))) + :to-throw 'neat-bencode-error)) + + (it "rejects a nil list element" + (expect (neat-bencode-encode '(1 nil 2)) :to-throw 'neat-bencode-error)) (it "encodes a list of integers" (expect (neat-bencode-encode '(1 2 3)) :to-equal "li1ei2ei3ee")) @@ -141,7 +158,7 @@ (it "preserves common nREPL-shaped messages" (dolist (msg '(((op . "describe")) ((op . "eval") (code . "(+ 1 2)") (id . "1")) - ((id . "2") (session . "abc") (status ("done"))))) + ((id . "2") (session . "abc") (status "done")))) (let* ((encoded (neat-bencode-encode msg)) (decoded (neat-bencode-decode encoded)) (re-encoded (neat-bencode-encode (car decoded)))) @@ -163,6 +180,14 @@ (expect (neat-bencode-get '(("foo" . 1)) "missing" 'fallback) :to-equal 'fallback))) +(describe "neat-bencode-dict-p" + (it "accepts alists with string or symbol keys" + (expect (neat-bencode-dict-p '(("id" . "1") (op . "eval"))) :to-be-truthy)) + + (it "rejects lists, the empty list and non-lists" + (dolist (obj '(("a" "b") nil 42 "id")) + (expect (neat-bencode-dict-p obj) :to-be nil)))) + (describe "neat-bencode-keys" (it "returns the keys in wire order" (expect (neat-bencode-keys '(("bar" . 2) ("foo" . 1))) diff --git a/test/neat-client-test.el b/test/neat-client-test.el index 15fdbde..adfd5ea 100644 --- a/test/neat-client-test.el +++ b/test/neat-client-test.el @@ -62,7 +62,8 @@ (expect (gethash "1" (neat-connection-pending conn)) :to-be nil))) (it "ignores messages whose id has no callback registered" - (let ((conn (neat-connection--make))) + (let ((conn (neat-connection--make)) + (neat-unhandled-message-functions nil)) (neat-client-test--push-bytes conn (neat-bencode-encode '(("id" . "99") ("value" . "?")))) ;; If we got here without throwing, we're good. @@ -72,17 +73,90 @@ ;; A stray `e' is the simplest malformed input: `neat-bencode-decode' ;; signals `neat-bencode-error' on it. The drain has to catch that ;; or the filter cycle dies silently. + (let* ((conn (neat-connection--make)) + (neat-connections (list conn)) + (debug-on-error nil)) + (expect (neat-client-test--push-bytes conn "e") :not :to-throw))) + + (it "dispatches what precedes malformed bytes, then disconnects" + ;; Past the bad byte there's no telling where the next message + ;; starts, so the trailing (valid-looking) message must not be + ;; dispatched; the pending callback hears about the disconnect + ;; instead. + (let* ((conn (neat-connection--make)) + (neat-connections (list conn)) + (neat-disconnect-functions nil) + (debug-on-error nil) + (got '())) + (puthash "1" (lambda (m) (push m got)) + (neat-connection-pending conn)) + (neat-client-test--push-bytes + conn (concat (neat-bencode-encode '(("id" . "1") ("value" . "ok"))) + "e" + (neat-bencode-encode '(("id" . "1") ("value" . "late"))))) + (setq got (nreverse got)) + (expect (length got) :to-equal 2) + (expect (neat-bencode-get (car got) "value") :to-equal "ok") + (expect (neat-bencode-get (cadr got) "value") :to-be nil) + (expect (member "done" (neat-bencode-get (cadr got) "status")) + :to-be-truthy) + (expect neat-connections :to-equal nil) + (expect (neat-connection-recv-buffer conn) :to-equal ""))) + + (it "skips top-level values that aren't dicts" (let ((conn (neat-connection--make)) - (debug-on-error nil)) - (expect (neat-client-test--push-bytes conn "e") :not :to-throw) - ;; And after dropping the bad bytes, a subsequent good message - ;; still dispatches normally. - (let ((got nil)) - (puthash "1" (lambda (m) (push m got)) - (neat-connection-pending conn)) - (neat-client-test--push-bytes - conn (neat-bencode-encode '(("id" . "1") ("value" . "ok")))) - (expect (length got) :to-equal 1)))) + (got '())) + (puthash "1" (lambda (m) (push m got)) + (neat-connection-pending conn)) + (expect (neat-client-test--push-bytes + conn (concat (neat-bencode-encode 42) + (neat-bencode-encode "id") + (neat-bencode-encode ["id" "1"]) + (neat-bencode-encode '(("id" . "1") + ("value" . "ok"))))) + :not :to-throw) + (expect (length got) :to-equal 1) + (expect (neat-bencode-get (car got) "value") :to-equal "ok"))) + + (it "ends a request on unknown-session even without done" + (let ((conn (neat-connection--make :host "h" :port 1)) + got) + (puthash "1" (lambda (m) (push m got)) (neat-connection-pending conn)) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "1") + ("status" "error" "unknown-session")))) + (expect (neat-bencode-get (car got) "status") + :to-equal '("error" "unknown-session" "done")) + (expect (gethash "1" (neat-connection-pending conn)) :to-be nil))) + + (it "treats a status sent as a plain string as a list of one" + (let ((conn (neat-connection--make)) + (got '())) + (puthash "1" (lambda (m) (push m got)) (neat-connection-pending conn)) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "1") ("status" . "done")))) + (expect (neat-bencode-get (car got) "status") :to-equal '("done")) + ;; So the request does finish. + (expect (gethash "1" (neat-connection-pending conn)) :to-be nil))) + + (it "treats any other status that isn't a list as no status" + (let ((conn (neat-connection--make)) + (got '())) + (puthash "1" (lambda (m) + ;; The usual callback idiom must not choke. + (member "done" (neat-bencode-get m "status")) + (push m got)) + (neat-connection-pending conn)) + (expect (neat-client-test--push-bytes + conn (concat (neat-bencode-encode '(("id" . "1") + ("status" . 7))) + (neat-bencode-encode '(("id" . "1") + ("value" . "next"))))) + :not :to-throw) + ;; The message behind the bad one still went through. + (expect (length got) :to-equal 2) + (expect (assoc "status" (cadr got)) :to-be nil) + (expect (gethash "1" (neat-connection-pending conn)) :not :to-be nil))) (it "shields the filter from a buggy callback (production semantics)" ;; The dispatch wraps callbacks in `condition-case-unless-debug', @@ -100,6 +174,287 @@ :not :to-throw) (expect (gethash "1" (neat-connection-pending conn)) :to-be nil)))) +(describe "neat-unhandled-message-functions" + :var (conn seen) + (before-each + (setq conn (neat-connection--make) + seen nil)) + + (it "gets messages that carry no id" + (let ((neat-unhandled-message-functions + (list (lambda (c m) (push (cons c m) seen))))) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("out" . "hi\n")))) + (expect (length seen) :to-equal 1) + (expect (car (car seen)) :to-be conn) + (expect (neat-bencode-get (cdr (car seen)) "out") :to-equal "hi\n"))) + + (it "gets messages for an id that was never registered" + (let ((neat-unhandled-message-functions + (list (lambda (_c m) (push m seen))))) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "99") ("out" . "?")))) + (expect (length seen) :to-equal 1))) + + (it "gets output for a request that already finished, and a second done" + (let ((neat-unhandled-message-functions + (list (lambda (_c m) (push m seen)))) + (got 0)) + (puthash "1" (lambda (_) (cl-incf got)) (neat-connection-pending conn)) + (neat-client-test--push-bytes + conn (concat (neat-bencode-encode '(("id" . "1") ("status" "done"))) + (neat-bencode-encode '(("id" . "1") ("out" . "late\n"))) + (neat-bencode-encode '(("id" . "1") ("status" "done"))))) + (expect got :to-equal 1) + (setq seen (nreverse seen)) + (expect (length seen) :to-equal 2) + (expect (neat-bencode-get (car seen) "out") :to-equal "late\n") + (expect (neat-bencode-get (cadr seen) "status") :to-equal '("done")))) + + (it "doesn't get messages a pending callback claims" + (let ((neat-unhandled-message-functions + (list (lambda (_c m) (push m seen))))) + (puthash "1" #'ignore (neat-connection-pending conn)) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "1") ("out" . "x")))) + (expect seen :to-be nil))) + + (it "prunes a finished request even when its callback is quit out of" + (let ((conn (neat-connection--make :host "h" :port 1 :evals '("1")))) + (puthash "1" (lambda (_) (signal 'quit nil)) + (neat-connection-pending conn)) + (condition-case nil + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "1") ("status" "done")))) + (quit nil)) + (expect (gethash "1" (neat-connection-pending conn)) :to-be nil) + (expect (neat-eval-pending-p conn) :to-be nil))) + + (it "survives a hook function that errors (production semantics)" + (let ((neat-unhandled-message-functions + (list (lambda (_c _m) (error "boom")))) + (debug-on-error nil) + (got nil)) + (puthash "2" (lambda (m) (push m got)) (neat-connection-pending conn)) + (expect (neat-client-test--push-bytes + conn (concat (neat-bencode-encode '(("out" . "x"))) + (neat-bencode-encode '(("id" . "2") ("value" . "1"))))) + :not :to-throw) + (expect (length got) :to-equal 1)))) + +(describe "neat-client--flush-pending" + (it "hands each pending callback a connection-closed done and no err" + (let* ((conn (neat-connection--make)) + (neat-connections (list conn)) + (neat-disconnect-functions nil) + got) + (puthash "7" (lambda (m) (push m got)) (neat-connection-pending conn)) + (neat-disconnect conn) + (expect got :to-equal + '((("id" . "7") ("status" "done" "connection-closed")))) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0)))) + +(describe "sync helpers" + (it "unregister the callback when the reply times out" + (let ((conn (neat-connection--make))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) #'ignore)) + (expect (neat-completions-sync conn "ma" nil 0.05) :to-be nil) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0) + (expect (neat-lookup-sync conn "map" nil 0.05) :to-be nil) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0)))) + + (it "treat a connection that closes mid-request as no answer" + (let ((conn (neat-connection--make))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) (neat-client--flush-pending conn)))) + (expect (neat-lookup-sync conn "map" nil 1) :to-be nil)))) + + (it "keep what arrived before the timeout" + (let ((conn (neat-connection--make)) + (sent nil)) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) + (unless sent + (setq sent t) + (neat-client-test--push-bytes + conn (neat-bencode-encode + '(("id" . "1") + ("completions" . ((("candidate" . "map"))))))))))) + (expect (neat-completions-sync conn "ma" nil 0.1) + :to-equal '((("candidate" . "map")))) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0)))) + + (it "don't take a wait cut short for a stalled server" + ;; A quit, or the throw `while-no-input' does when a completion UI + ;; gets new input, says nothing about the server. + (let ((conn (neat-connection--make :evals '("5")))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) (throw 'neat-test-input t)))) + (catch 'neat-test-input + (neat-completions-sync conn "ma" nil 1)) + (expect (neat-connection-stalled conn) :to-be nil) + (condition-case nil + (cl-letf (((symbol-function 'accept-process-output) + (lambda (&rest _) (signal 'quit nil)))) + (neat-completions-sync conn "ma" nil 1)) + (quit nil)) + (expect (neat-connection-stalled conn) :to-be nil) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0)))) + + (it "unregister the callback when the wait is quit out of" + (let ((conn (neat-connection--make))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) (signal 'quit nil)))) + (condition-case nil + (neat-completions-sync conn "ma" nil 1) + (quit nil)) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0)))) + + (it "return what arrived before done" + (let ((conn (neat-connection--make))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) + (neat-client-test--push-bytes + conn (neat-bencode-encode + '(("id" . "1") + ("completions" . ((("candidate" . "map")))) + ("status" "done"))))))) + (expect (neat-completions-sync conn "ma" nil 1) + :to-equal '((("candidate" . "map")))))))) + +(defun neat-client-test--fake-server (conn reply-fn) + "Make CONN's sends get an answer from REPLY-FN. +REPLY-FN gets each decoded request and returns the reply dicts; the +returned function goes in place of `process-send-string'." + (lambda (_proc bytes) + (let ((request (car (neat-bencode-decode bytes)))) + (dolist (reply (funcall reply-fn request)) + (neat-client-test--push-bytes + conn (neat-bencode-encode + (cons (cons "id" (neat-bencode-get request "id")) reply))))))) + +(describe "sync tooling ops and an ns the server turns down" + :var (conn sent-ns) + (before-each + (setq conn (neat-connection--make :host "h" :port 1) + sent-ns nil)) + + (it "retry completions without the ns" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) #'ignore) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (req) + (push (neat-bencode-get req "ns") sent-ns) + (if (neat-bencode-get req "ns") + '((("status" "done" "error" "namespace-not-found"))) + '((("completions" . ((("candidate" . "map")))) + ("status" "done")))))))) + (expect (neat-completions-sync conn "ma" "not.loaded") + :to-equal '((("candidate" . "map")))) + (expect (nreverse sent-ns) :to-equal '("not.loaded" nil)))) + + (it "retry lookup without the ns after a bare error" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) #'ignore) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (req) + (push (neat-bencode-get req "ns") sent-ns) + (if (neat-bencode-get req "ns") + '((("status" "error" "done"))) + '((("info" . (("name" . "map"))) + ("status" "done")))))))) + (expect (neat-lookup-sync conn "map" "not.loaded") + :to-equal '(("name" . "map"))) + (expect (nreverse sent-ns) :to-equal '("not.loaded" nil)))) + + (it "don't retry on an error that has nothing to do with the ns" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) #'ignore) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (req) + (push (neat-bencode-get req "ns") sent-ns) + '((("status" "done" "error" "unknown-op"))))))) + (expect (neat-completions-sync conn "ma" "user") :to-be nil) + (expect sent-ns :to-equal '("user")))) + + (it "retry the async lookup without the ns too" + (let (got) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (req) + (push (neat-bencode-get req "ns") sent-ns) + (if (neat-bencode-get req "ns") + '((("status" "done" "error" "namespace-not-found"))) + '((("info" . (("name" . "map"))) + ("status" "done")))))))) + (neat-lookup-async conn "map" "not.loaded" 1 + (lambda (i) (setq got i)))) + (expect got :to-equal '(("name" . "map"))) + (expect (nreverse sent-ns) :to-equal '("not.loaded" nil)))) + + (it "don't retry when the ns was fine" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) #'ignore) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (req) + (push (neat-bencode-get req "ns") sent-ns) + '((("status" "done"))))))) + (expect (neat-completions-sync conn "zz" "user") :to-be nil) + (expect sent-ns :to-equal '("user"))))) + +(describe "neat-close-session-sync" + (it "returns non-nil once the server confirms the close" + (let ((conn (neat-connection--make :session "S-1"))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) + (neat-client-test--push-bytes + conn (neat-bencode-encode + '(("id" . "1") ("status" "done" "session-closed"))))))) + (expect (neat-close-session-sync conn) :to-be-truthy) + (expect (neat-connection-session conn) :to-be nil)))) + + (it "gives up after the timeout" + (let ((conn (neat-connection--make :session "S-1"))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) #'ignore)) + (expect (neat-close-session-sync conn nil 0.05) :to-be nil) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0)))) + + (it "doesn't count a connection that went away as confirmation" + (let ((conn (neat-connection--make :session "S-1"))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) + (lambda (&rest _) (neat-client--flush-pending conn)))) + (expect (neat-close-session-sync conn) :to-be nil))))) + (describe "neat-clone-session" (it "captures new-session from the response and assigns it to the connection" (let ((conn (neat-connection--make)) @@ -134,6 +489,140 @@ "versions") :not :to-be nil))))) +(describe "neat-describe (ops)" + (it "keeps the ops when done comes in a message of its own" + (let ((conn (neat-connection--make))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore)) + (neat-describe conn) + ;; Empty dicts can't be written as alists, so raw bencode it is. + (neat-client-test--push-bytes + conn (concat "d2:id1:13:opsd5:clonede4:evaldeee" + (neat-bencode-encode '(("id" . "1") ("status" "done"))))) + (expect (neat-op-supported-p conn "eval") :to-be-truthy) + (expect (neat-op-supported-p conn "interrupt") :to-be nil))))) + +(describe "neat-op-supported-p" + (it "reads ops sent as a dict" + (let ((conn (neat-connection--make + :capabilities (car (neat-bencode-decode + "d3:opsd5:clonede4:evald3:doc1:xeeee"))))) + (expect (neat-op-supported-p conn "eval") :to-be-truthy) + (expect (neat-op-supported-p conn "clone") :to-be-truthy) + (expect (neat-op-supported-p conn "interrupt") :to-be nil))) + + (it "reads ops sent as a list" + (let ((conn (neat-connection--make + :capabilities (car (neat-bencode-decode + "d3:opsl5:clone4:evalee"))))) + (expect (neat-op-supported-p conn "eval") :to-be-truthy) + (expect (neat-op-supported-p conn "lookup") :to-be nil))) + + (it "treats every op as supported before describe answers" + (expect (neat-op-supported-p (neat-connection--make) "interrupt") + :to-be-truthy)) + + (it "treats every op as supported when describe lists none" + (dolist (caps (list '(("versions" . (("nrepl" . (("major" . 1)))))) + (car (neat-bencode-decode "d3:opsdee")) + (car (neat-bencode-decode "d3:opslee")))) + (expect (neat-op-supported-p (neat-connection--make :capabilities caps) + "interrupt") + :to-be-truthy)))) + +(describe "neat-interrupt" + (it "builds an interrupt op with session and interrupt-id" + (let ((conn (neat-connection--make)) + sent) + (setf (neat-connection-session conn) "S-3") + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (lambda (_p s) (setq sent s)))) + (neat-interrupt conn nil "42") + (let ((decoded (car (neat-bencode-decode sent)))) + (expect (neat-bencode-get decoded "op") :to-equal "interrupt") + (expect (neat-bencode-get decoded "session") :to-equal "S-3") + (expect (neat-bencode-get decoded "interrupt-id") + :to-equal "42"))))) + + (it "omits interrupt-id when none is given" + (let ((conn (neat-connection--make)) + sent) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (lambda (_p s) (setq sent s)))) + (neat-interrupt conn "S-4") + (let ((decoded (car (neat-bencode-decode sent)))) + (expect (neat-bencode-get decoded "session") :to-equal "S-4") + (expect (assoc "interrupt-id" decoded) :to-be nil)))))) + +(describe "neat-close-session" + (it "builds a close op for the current session" + (let ((conn (neat-connection--make)) + sent) + (setf (neat-connection-session conn) "S-5") + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (lambda (_p s) (setq sent s)))) + (neat-close-session conn) + (let ((decoded (car (neat-bencode-decode sent)))) + (expect (neat-bencode-get decoded "op") :to-equal "close") + (expect (neat-bencode-get decoded "session") :to-equal "S-5"))))) + + (it "clears the connection's session when closing it" + (let ((conn (neat-connection--make :session "S-5"))) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore)) + (neat-close-session conn) + (expect (neat-connection-session conn) :to-be nil)))) + + (it "keeps the connection's session when closing another one" + (let ((conn (neat-connection--make :session "S-5")) + sent) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (lambda (_p s) (setq sent s)))) + (neat-close-session conn "S-6") + (expect (neat-bencode-get (car (neat-bencode-decode sent)) "session") + :to-equal "S-6") + (expect (neat-connection-session conn) :to-equal "S-5"))))) + +(describe "neat-response-error" + (it "describes namespace-not-found, naming the ns when the server does" + (expect (neat-response-error + '(("status" "done" "error" "namespace-not-found") + ("ns" . "my.typo"))) + :to-equal "namespace not found: my.typo") + (expect (neat-response-error + '(("status" "namespace-not-found" "done" "error"))) + :to-equal "namespace not found")) + + (it "describes unknown-session" + (expect (neat-response-error '(("status" "error" "unknown-session" "done"))) + :to-equal "unknown session")) + + (it "describes unknown-op, naming the op when the server does" + (expect (neat-response-error + '(("status" "done" "error" "unknown-op") ("op" . "load-file"))) + :to-equal "unknown op: load-file")) + + (it "describes a bare error" + (expect (neat-response-error '(("status" "error" "done"))) + :to-equal "error")) + + (it "leaves a bare error alone when the request already explained it" + (expect (neat-response-error '(("status" "error" "done")) t) :to-be nil)) + + (it "leaves an error that comes with its own explanation alone" + (expect (neat-response-error '(("status" "error") ("err" . "boom\n"))) + :to-be nil) + (expect (neat-response-error '(("status" "error") ("ex" . "boom"))) + :to-be nil)) + + (it "is nil for ordinary statuses" + (dolist (status '(("done") ("eval-error") ("need-input") nil)) + (expect (neat-response-error `(("status" . ,status))) :to-be nil)))) + (describe "neat-eval" (it "includes the session and code fields in the sent message" (let ((conn (neat-connection--make)) @@ -176,6 +665,121 @@ (expect (assoc "column" decoded) :to-be nil) (expect (assoc "ns" decoded) :to-be nil)))))) +(describe "neat-eval-pending-p" + :var (conn) + (before-each + (setq conn (neat-connection--make :host "h" :port 1))) + + (it "is true from an eval until its done" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore)) + (expect (neat-eval-pending-p conn) :to-be nil) + (neat-eval conn "(+ 1 2)") + (expect (neat-eval-pending-p conn) :to-be-truthy) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "1") ("value" . "3")))) + (expect (neat-eval-pending-p conn) :to-be-truthy) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "1") ("status" "done")))) + (expect (neat-eval-pending-p conn) :to-be nil))) + + (it "counts load-file but not tooling ops" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore)) + (neat-completions conn "ma") + (neat-lookup conn "map") + (expect (neat-eval-pending-p conn) :to-be nil) + (neat-load-file conn "(def x 1)") + (expect (neat-eval-pending-p conn) :to-be-truthy))) + + (it "clears when the connection goes away" + (let ((neat-connections (list conn)) + (neat-disconnect-functions nil)) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore)) + (neat-eval conn "(Thread/sleep 10000)" :callback #'ignore)) + (neat-disconnect conn) + (expect (neat-eval-pending-p conn) :to-be nil)))) + +(describe "neat-tooling-stalled-p" + :var (conn) + (before-each + (setq conn (neat-connection--make :host "h" :port 1))) + + (it "turns on when a sync request times out behind an eval" + (setf (neat-connection-evals conn) '("5")) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) #'ignore)) + (neat-completions-sync conn "ma" nil 0.05)) + (expect (neat-tooling-stalled-p conn) :to-be-truthy)) + + (it "stays off when the timeout had no eval to blame" + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore) + ((symbol-function 'accept-process-output) #'ignore)) + (neat-completions-sync conn "ma" nil 0.05)) + (expect (neat-connection-stalled conn) :to-be nil)) + + (it "turns off once the evals are done" + (setf (neat-connection-evals conn) '("5") + (neat-connection-stalled conn) (float-time)) + (neat-client-test--push-bytes + conn (neat-bencode-encode '(("id" . "5") ("status" "done")))) + (expect (neat-tooling-stalled-p conn) :to-be nil)) + + (it "turns off when a sync request gets answered mid-eval" + (setf (neat-connection-evals conn) '("5") + (neat-connection-stalled conn) (float-time)) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) #'ignore) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (_req) '((("info" . (("name" . "map"))) + ("status" "done"))))))) + (neat-lookup-sync conn "map")) + (expect (neat-tooling-stalled-p conn) :to-be nil)) + + (it "lets one request through as a probe every so often" + (let ((neat-tooling-probe-interval 5)) + (setf (neat-connection-evals conn) '("5") + (neat-connection-stalled conn) (- (float-time) 10)) + (expect (neat-tooling-stalled-p conn) :to-be nil) + ;; The probe restarted the clock, so the next one has to wait. + (expect (neat-tooling-stalled-p conn) :to-be-truthy))) + + (it "turns on when an async lookup times out behind an eval" + (let (got (called nil)) + (setf (neat-connection-evals conn) '("5")) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) #'ignore)) + (neat-lookup-async conn "map" nil 0.01 + (lambda (info) (setq called t got info))) + (sleep-for 0.1)) + (expect called :to-be-truthy) + (expect got :to-be nil) + (expect (hash-table-count (neat-connection-pending conn)) :to-equal 0) + (expect (neat-tooling-stalled-p conn) :to-be-truthy))) + + (it "turns off when an async lookup is answered mid-eval" + (setf (neat-connection-evals conn) '("5") + (neat-connection-stalled conn) (float-time)) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (neat-client-test--fake-server + conn (lambda (_req) '((("info" . (("name" . "map"))) + ("status" "done"))))))) + (neat-lookup-async conn "map" nil 1 #'ignore)) + (expect (neat-tooling-stalled-p conn) :to-be nil)) + + (it "turns off when the connection goes away" + (let ((neat-connections (list conn)) + (neat-disconnect-functions nil)) + (setf (neat-connection-evals conn) '("5") + (neat-connection-stalled conn) (float-time)) + (neat-disconnect conn) + (expect (neat-connection-stalled conn) :to-be nil)))) + (describe "neat-load-file" (it "builds a load-file op with contents and metadata" (let ((conn (neat-connection--make)) @@ -423,6 +1027,21 @@ (push (neat-send conn '((op . "describe"))) ids) (expect (nreverse ids) :to-equal '("1" "2" "3"))))) + (it "leaves nothing behind when the message can't be encoded" + (let ((conn (neat-connection--make)) + (neat-log-messages t) + logged) + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (lambda (&rest _) (error "Should not send"))) + ((symbol-function 'neat-client--log) + (lambda (&rest _) (setq logged t)))) + (expect (neat-send conn '((op . "eval") (ns . nil)) #'ignore) + :to-throw 'neat-bencode-error) + (expect (hash-table-count (neat-connection-pending conn)) + :to-equal 0) + (expect logged :to-be nil)))) + (it "errors when the connection is not live" (let ((conn (neat-connection--make))) (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil))) diff --git a/test/neat-integration-test.el b/test/neat-integration-test.el index 6738260..bd7c7c9 100644 --- a/test/neat-integration-test.el +++ b/test/neat-integration-test.el @@ -1,18 +1,20 @@ -;;; neat-integration-test.el --- Live nREPL integration tests -*- lexical-binding: t; -*- +;;; neat-integration-test.el --- End-to-end tests against nREPL -*- lexical-binding: t; -*- ;;; Commentary: -;; Live integration tests against real nREPL implementations. Gated -;; behind NEAT_INTEGRATION because spinning up real servers adds a few -;; seconds to the suite and may need network access on the first run -;; (e.g. to fetch the Clojure nREPL dependency). +;; End-to-end tests that drive the client and the REPL buffer against +;; a real nREPL server (the reference implementation, started through +;; the Clojure CLI). They cover what the unit tests can only fake with +;; canned messages: REPL rendering, the need-input round trip, +;; interrupts, error statuses and late output, as they come off a real +;; wire. ;; -;; Each entry in `neat-it--server-impls' below describes one -;; implementation. At load time we walk the list, and for every impl -;; whose executable is on PATH we register a `describe' block that -;; runs the same set of assertions. Implementations that aren't -;; installed locally are silently skipped, so contributors can run -;; whichever subset they have. +;; Whether a server speaks nREPL properly is a different question, and +;; proof (https://github.com/nrepl/proof) is the tool for that one. +;; +;; Gated behind NEAT_INTEGRATION because booting the JVM adds a few +;; seconds to the suite and the first run needs network access to +;; fetch nREPL. Skipped when `clojure' isn't on PATH. ;; ;; Run with: ;; @@ -22,133 +24,53 @@ (require 'buttercup) (require 'cl-lib) -(require 'neat-bencode) -(require 'neat-client) - - -;;;; Server descriptors - -(defconst neat-it--clojure-deps - "{:deps {nrepl/nrepl {:mvn/version \"1.3.0\"}}}") - -(defconst neat-it--server-impls - `((:name "Clojure" - :executable "clojure" - :command-fn ,(lambda () - (list "clojure" "-Sdeps" neat-it--clojure-deps - "-M" "-m" "nrepl.cmdline" "--port" "0")) - :port-regexp "nREPL server started on port \\([0-9]+\\)" - :startup-timeout 120) - (:name "Babashka" - :executable "bb" - :command-fn ,(lambda () (list "bb" "nrepl-server" "localhost:0")) - :port-regexp "Started nREPL server at [^:]+:\\([0-9]+\\)" - :startup-timeout 30) - (:name "Basilisp" - :executable "basilisp" - :command-fn ,(lambda () (list "basilisp" "nrepl-server")) - ;; Basilisp prints the same banner shape as nrepl/nrepl, so we - ;; can reuse the Clojure regex verbatim. - :port-regexp "nREPL server started on port \\([0-9]+\\)" - :startup-timeout 30) - (:name "let-go" - :executable "let-go" - ;; let-go's `-p 0' is broken upstream (banner and .nrepl-port both - ;; say `0' while the server listens on a random ephemeral port), so - ;; we pre-allocate a free port and pass it explicitly. The regex - ;; here is just a readiness signal -- the port we use is the one - ;; we picked, not whatever's in the banner. - :port-fn ,#'neat-it--free-port - :command-fn ,(lambda (port) - (list "let-go" "-n" "-p" (number-to-string port))) - :port-regexp "nREPL server started" - :startup-timeout 30)) - "Implementations the integration suite knows how to drive. - -Each entry is a plist: - :name human-readable label. - :executable the binary the suite skips if absent from PATH. - :command-fn returns the process command list. Called with no - args by default, or with a pre-allocated port when - `:port-fn' is provided. - :port-regexp regex matched against stdout. When `:port-fn' is - absent, group 1 must capture the port the server - chose; when `:port-fn' is provided, the match just - signals \"server is up\". - :port-fn optional zero-arg fn returning a free port the - framework reserves before launching. Use for - servers that don't reliably announce the OS-assigned - port back on stdout. - :startup-timeout seconds to wait for the readiness signal.") - - -;;;; Subprocess lifecycle +(require 'neat) + +(defconst neat-it--command + '("clojure" "-Sdeps" "{:deps {nrepl/nrepl {:mvn/version \"1.3.0\"}}}" + "-M" "-m" "nrepl.cmdline" "--port" "0") + "Command that starts the nREPL server the suite talks to.") + +(defconst neat-it--port-regexp "nREPL server started on port \\([0-9]+\\)" + "Regexp matching the server's banner; group 1 is the port.") + +(defconst neat-it--startup-timeout 120 + "Seconds to wait for the server banner.") + + +;;;; Server lifecycle (defvar neat-it--server-process nil) (defvar neat-it--server-port nil) (defvar neat-it--server-output "") -(defvar neat-it--server-ready nil) -(defvar neat-it--port-regexp nil) - -(defun neat-it--free-port () - "Return a TCP port number that's free on 127.0.0.1 right now. -There's a small race window between us closing the listener and the -subprocess claiming the port; on a quiet test machine it doesn't bite." - (let* ((proc (make-network-process - :name "neat-it-port-finder" - :host "127.0.0.1" - :service t - :server t - :family 'ipv4 - :noquery t)) - (port (process-contact proc :service))) - (delete-process proc) - port)) (defun neat-it--server-filter (_proc chunk) - "Watch the server's output CHUNK for the readiness signal. -Captures the port from regex group 1 when the port wasn't -pre-allocated; otherwise just flips `neat-it--server-ready' once -the banner appears." + "Collect the server's output CHUNK and pick the port out of the banner." (setq neat-it--server-output (concat neat-it--server-output chunk)) - (when (and (not neat-it--server-ready) + (when (and (not neat-it--server-port) (string-match neat-it--port-regexp neat-it--server-output)) - (unless neat-it--server-port - (setq neat-it--server-port - (string-to-number (match-string 1 neat-it--server-output)))) - (setq neat-it--server-ready t))) - -(defun neat-it--start-server (impl) - "Boot the nREPL server described by IMPL and return its port. -Errors out if the readiness banner doesn't appear within the impl's -timeout." - (let* ((port-fn (plist-get impl :port-fn)) - (port (and port-fn (funcall port-fn))) - (cmd (if port - (funcall (plist-get impl :command-fn) port) - (funcall (plist-get impl :command-fn)))) - (timeout (or (plist-get impl :startup-timeout) 60))) - (setq neat-it--server-port port - neat-it--server-output "" - neat-it--server-ready nil - neat-it--port-regexp (plist-get impl :port-regexp)) - (let ((proc (make-process - :name (format "neat-it-%s" (plist-get impl :name)) - :buffer nil - :command cmd - :filter #'neat-it--server-filter - :noquery t - :connection-type 'pipe))) - (setq neat-it--server-process proc) - (let ((deadline (+ (float-time) timeout))) - (while (and (not neat-it--server-ready) - (process-live-p proc) - (< (float-time) deadline)) - (accept-process-output proc 0.5)))) - (unless neat-it--server-ready - (error "Neat: %s nREPL server failed to start: %s" - (plist-get impl :name) neat-it--server-output)) - neat-it--server-port)) + (setq neat-it--server-port + (string-to-number (match-string 1 neat-it--server-output))))) + +(defun neat-it--start-server () + "Boot the nREPL server and return its port." + (setq neat-it--server-port nil + neat-it--server-output "" + neat-it--server-process + (make-process :name "neat-it-nrepl" + :buffer nil + :command neat-it--command + :filter #'neat-it--server-filter + :noquery t + :connection-type 'pipe)) + (let ((deadline (+ (float-time) neat-it--startup-timeout))) + (while (and (not neat-it--server-port) + (process-live-p neat-it--server-process) + (< (float-time) deadline)) + (accept-process-output neat-it--server-process 0.5))) + (or neat-it--server-port + (error "Neat: nREPL server failed to start: %s" + neat-it--server-output))) (defun neat-it--stop-server () "Terminate the test nREPL server, if any." @@ -156,108 +78,142 @@ timeout." (kill-process neat-it--server-process)) (setq neat-it--server-process nil neat-it--server-port nil - neat-it--server-output "" - neat-it--server-ready nil - neat-it--port-regexp nil)) + neat-it--server-output "")) + + +;;;; Helpers -(defun neat-it--wait-until (conn predicate &optional timeout) - "Pump CONN's process output until PREDICATE returns non-nil or TIMEOUT elapses. -TIMEOUT defaults to 10 seconds." - (let ((deadline (+ (float-time) (or timeout 10)))) +(defun neat-it--wait-until (predicate &optional timeout) + "Pump process output until PREDICATE returns non-nil. +Give up after TIMEOUT seconds (default 15). Return PREDICATE's +last value." + (let ((deadline (+ (float-time) (or timeout 15)))) (while (and (not (funcall predicate)) (< (float-time) deadline)) - (accept-process-output (neat-connection-process conn) 0.1)))) - - -;;;; Suite registration - -(when (getenv "NEAT_INTEGRATION") - (dolist (impl neat-it--server-impls) - (when (executable-find (plist-get impl :executable)) - ;; Fresh per-iteration binding so the lambdas inside the - ;; describe block close over THIS impl, not the dolist's - ;; shared slot. - (let ((impl impl)) - (describe (format "integration against %s nREPL" - (plist-get impl :name)) - :var (conn responses) - - (before-all - (neat-it--start-server impl)) - - (after-all - (neat-it--stop-server)) - - (before-each - (setq responses nil) - (setq conn (neat-connect "127.0.0.1" neat-it--server-port))) - - (after-each - (when conn - (ignore-errors (neat-disconnect conn)) - (setq conn nil))) - - (it "describes the server's capabilities" - (let (done) - (neat-describe - conn - (lambda (r) - (push r responses) - (when (member "done" (neat-bencode-get r "status")) - (setq done t)))) - (neat-it--wait-until conn (lambda () done) 15) - (expect done :to-be-truthy) - (expect (or (neat-bencode-get - (neat-connection-capabilities conn) "versions") - (neat-bencode-get - (neat-connection-capabilities conn) "ops")) - :not :to-be nil))) - - (it "clones a session and evaluates an expression" - (neat-clone-session conn) - (neat-it--wait-until - conn (lambda () (neat-connection-session conn)) 15) - (expect (neat-connection-session conn) :not :to-be nil) - - (let ((id (neat-eval - conn "(+ 1 2)" - :callback (lambda (r) (push r responses))))) - (neat-it--wait-until - conn (lambda () - (not (gethash id (neat-connection-pending conn)))) - 15) - (let ((value-resp (cl-find-if (lambda (r) - (neat-bencode-get r "value")) - responses))) - (expect value-resp :not :to-be nil) - (expect (neat-bencode-get value-resp "value") - :to-equal "3")))) - - (it "captures stdout from the evaluated code" - (neat-clone-session conn) - (neat-it--wait-until - conn (lambda () (neat-connection-session conn)) 15) - - (let ((id (neat-eval - conn "(do (println \"hi\") :ok)" - :callback (lambda (r) (push r responses))))) - (neat-it--wait-until - conn (lambda () - (not (gethash id (neat-connection-pending conn)))) - 15) - ;; Different implementations chunk `out' differently: - ;; Clojure batches "hi\\n", Basilisp splits it into "hi" - ;; and "\\n" messages. Concatenate everything we got. - (let ((all-out (mapconcat - (lambda (r) (or (neat-bencode-get r "out") "")) - (reverse responses) - "")) - (val-resp (cl-find-if - (lambda (r) (neat-bencode-get r "value")) - responses))) - (expect all-out :to-match "hi") - (expect val-resp :not :to-be nil) - (expect (neat-bencode-get val-resp "value") - :to-equal ":ok"))))))))) + (accept-process-output nil 0.1)) + (funcall predicate))) + +(defun neat-it--text () + "Return the current buffer's text without properties." + (buffer-substring-no-properties (point-min) (point-max))) + +(defun neat-it--type (code) + "Type CODE at the REPL prompt and submit it." + (goto-char (point-max)) + (insert code) + (neat-repl-return)) + +(defun neat-it--send (code) + "Submit CODE at the REPL prompt and wait for the next prompt." + (neat-it--type code) + (neat-it--wait-until (lambda () neat-repl--prompt-start))) + + +;;;; Suite + +(when (and (getenv "NEAT_INTEGRATION") + (executable-find (car neat-it--command))) + (describe "neat against nREPL" + :var (conn repl) + + (before-all + (neat-it--start-server)) + + (after-all + (neat-it--stop-server)) + + (before-each + (let ((neat-repl-history-file nil)) + (setq conn (neat "127.0.0.1" neat-it--server-port))) + (setq repl (neat-repl-buffer-for conn)) + (neat-it--wait-until + (lambda () + (and (neat-connection-session conn) + (neat-connection-capabilities conn) + (buffer-local-value 'neat-repl--prompt-start repl))))) + + (after-each + (when (buffer-live-p repl) + (kill-buffer repl)) + (when (neat-connection-live-p conn) + (neat-disconnect conn)) + (setq neat-default-connection nil + conn nil + repl nil)) + + (it "renders a value and a prompt in the REPL's namespace" + (with-current-buffer repl + (neat-it--send "(+ 1 2)") + (expect (neat-it--text) :to-match "\n3\nuser> \\'"))) + + (it "renders stdout ahead of the value" + (with-current-buffer repl + (neat-it--send "(do (println \"hi\") :ok)") + (expect (neat-it--text) :to-match "\nhi\n:ok\nuser> \\'"))) + + (it "follows in-ns in the prompt and in tooling ops" + (with-current-buffer repl + (neat-it--send "(in-ns 'neat.it)") + (expect (neat-it--text) :to-match "neat\\.it> \\'") + (expect (neat-connection-ns conn) :to-equal "neat.it"))) + + (it "answers need-input from the minibuffer" + (spy-on 'read-from-minibuffer :and-return-value "hello") + (with-current-buffer repl + (neat-it--send "(read-line)") + (expect 'read-from-minibuffer :to-have-been-called) + (expect (neat-it--text) :to-match "\n\"hello\"\nuser> \\'"))) + + (it "sends end-of-file from the stdin prompt" + (spy-on 'read-from-minibuffer + :and-call-fake (lambda (&rest _) + (setq neat-repl--stdin-eof t) + "")) + (with-current-buffer repl + (neat-it--send "(read-line)") + (expect (neat-it--text) :to-match "\nnil\nuser> \\'"))) + + (it "interrupts a running eval" + (with-current-buffer repl + (neat-it--type "(Thread/sleep 60000)") + ;; Give the eval a moment to actually start running. + (neat-it--wait-until #'ignore 1) + (expect (neat-eval-pending-p conn) :to-be-truthy) + (neat-repl-interrupt) + (expect (neat-it--wait-until (lambda () neat-repl--prompt-start)) + :to-be-truthy) + (expect (neat-eval-pending-p conn) :to-be nil))) + + (it "reports a namespace that doesn't exist" + (with-temp-buffer + (setq neat-ns "neat.no-such-ns") + (insert "(+ 1 2)") + (neat-eval-buffer)) + (with-current-buffer repl + (expect (neat-it--wait-until + (lambda () + (string-match-p ";; namespace not found: neat\\.no-such-ns" + (neat-it--text)))) + :to-be-truthy))) + + (it "reports an unknown session and clones a new one" + (spy-on 'y-or-n-p :and-return-value t) + (setf (neat-connection-session conn) "neat-no-such-session") + (with-current-buffer repl + (neat-it--send "(+ 1 2)") + (expect (neat-it--text) :to-match ";; unknown session\n") + (expect (neat-it--wait-until (lambda () (neat-connection-session conn))) + :to-be-truthy) + (neat-it--send "(+ 40 2)") + (expect (neat-it--text) :to-match "\n42\nuser> \\'"))) + + (it "shows output that arrives after the eval is done" + (with-current-buffer repl + (neat-it--send "(do (future (Thread/sleep 300) (println \"late\")) :ok)") + (expect (neat-it--wait-until + (lambda () (string-match-p "^late$" (neat-it--text)))) + :to-be-truthy) + ;; Above the prompt, not tacked on after it. + (expect (neat-it--text) :to-match "\n:ok\nlate\nuser> \\'"))))) ;;; neat-integration-test.el ends here diff --git a/test/neat-repl-test.el b/test/neat-repl-test.el index e6c62ad..7a6f883 100644 --- a/test/neat-repl-test.el +++ b/test/neat-repl-test.el @@ -13,6 +13,25 @@ (require 'neat-bencode) (require 'neat-repl) +(defmacro neat-repl-test--with-repl (conn &rest body) + "Run BODY in a real `neat-repl-mode' buffer for a fake connection. +CONN is bound to the connection, which has no network process; the +buffer gets its usual comint pipe process, so rendering really +inserts text." + (declare (indent 1)) + `(let* ((neat-repl-history-file nil) + (,conn (neat-connection--make :host "h" :port 1)) + (buf (neat-repl-create-buffer ,conn))) + (unwind-protect + (with-current-buffer buf ,@body) + ;; Keep the kill-buffer cleanup away from the fake connection. + (with-current-buffer buf (setq neat-current-connection nil)) + (kill-buffer buf)))) + +(defun neat-repl-test--text () + "Return the current buffer's text without properties." + (buffer-substring-no-properties (point-min) (point-max))) + (describe "neat-repl--input-complete-p" (it "accepts an empty string as complete" (expect (neat-repl--input-complete-p "") :to-be-truthy)) @@ -71,40 +90,627 @@ '(("id" . "1") ("ns" . "myapp.core") ("value" . "nil") - ("status" "done"))) + ("status" "done")) + (neat-repl--request-create)) (expect neat-repl--current-ns :to-equal "myapp.core"))) (it "leaves `neat-repl--current-ns' alone when the response has no `ns'" (with-temp-buffer (setq-local neat-repl--current-ns "stays") (neat-repl--render-response - '(("id" . "1") ("value" . "nil") ("status" "done"))) - (expect neat-repl--current-ns :to-equal "stays")))) + '(("id" . "1") ("value" . "nil") ("status" "done")) + (neat-repl--request-create)) + (expect neat-repl--current-ns :to-equal "stays"))) + + (it "follows the `ns' reported for input typed into the REPL" + (neat-repl-test--with-repl _conn + (let (callback) + (cl-letf (((symbol-function 'neat-connection-live-p) (lambda (_) t)) + ((symbol-function 'neat-eval) + (lambda (_c _code &rest plist) + (setq callback (plist-get plist :callback))))) + (neat-repl--input-sender nil "(in-ns 'myapp.core)") + (funcall callback '(("id" . "1") ("ns" . "myapp.core") + ("value" . "nil"))) + (expect neat-repl--current-ns :to-equal "myapp.core"))))) + + (it "remembers the REPL's ns on the connection for tooling ops" + (neat-repl-test--with-repl conn + (neat-repl--render-response + '(("id" . "1") ("ns" . "myapp.core") ("value" . "nil")) + (neat-repl--request-create)) + (expect (neat-connection-ns conn) :to-equal "myapp.core"))) + + (it "ignores the `ns' of an eval that named its own" + ;; The source buffer sent an explicit ns, which the server only + ;; binds for that eval; the REPL is still wherever it was. + (neat-repl-test--with-repl conn + (setq neat-repl--current-ns "user") + (neat-repl--insert-prompt) + (let ((request (neat-repl--request-create :ns "myapp.core"))) + (dolist (resp '((("id" . "1") ("ns" . "myapp.core") ("value" . "nil")) + (("id" . "1") ("status" "done")))) + (neat-repl--render-response resp request))) + (expect neat-repl--current-ns :to-equal "user") + (expect (neat-connection-ns conn) :to-be nil) + (expect (neat-repl-test--text) :to-equal "nil\nuser> "))) + + (it "redraws a waiting prompt when a source-buffer eval moves the session" + (neat-repl-test--with-repl _conn + (setq neat-repl--current-ns "user") + (neat-repl--insert-prompt) + (goto-char (point-max)) + (insert "(foo") + (neat-repl-test--render-all + '((("id" . "1") ("ns" . "myapp.core") ("value" . "nil")) + (("id" . "1") ("status" "done"))) + 'source) + (expect (neat-repl-test--text) :to-equal "nil\nmyapp.core> (foo") + (expect (buffer-substring-no-properties + neat-repl--prompt-start + (process-mark (get-buffer-process (current-buffer)))) + :to-equal "myapp.core> "))) + + (it "follows a source-buffer eval that named no ns" + ;; Say it ran `(ns myapp.core)': the session really moved. + (neat-repl-test--with-repl conn + (setq neat-repl--current-ns "user") + (neat-repl-test--render-all + '((("id" . "1") ("ns" . "myapp.core") ("value" . "nil")) + (("id" . "1") ("status" "done"))) + 'source) + (expect neat-repl--current-ns :to-equal "myapp.core") + (expect (neat-connection-ns conn) :to-equal "myapp.core")))) + +(defun neat-repl-test--render-all (responses &optional source) + "Render RESPONSES in order as replies to one request. +The request counts as input typed into the REPL, unless SOURCE is +non-nil, in which case it's a source-buffer eval." + (let ((request (neat-repl--request-create :from-repl (not source)))) + (dolist (resp responses) + (neat-repl--render-response resp request)))) + +(describe "neat-repl--render-response (output)" + (it "renders a value and then a prompt on done" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("value" . "3")) + (("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "3\nneat> "))) + + (it "renders out before the value" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("out" . "hi\n")) + (("id" . "1") ("value" . ":ok")) + (("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "hi\n:ok\nneat> ") + (expect (get-text-property 1 'face) :to-be 'neat-repl-output))) + + (it "shows err and drops an ex that came after it" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("err" . "Traceback: boom\n")) + (("id" . "1") ("ex" . "Traceback: boom") ("status" "eval-error")) + (("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "Traceback: boom\nneat> "))) + + (it "drops an ex that came before err" + ;; nREPL sends the eval-error status with `ex' first, then `err'. + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("ex" . "class java.lang.ArithmeticException") + ("status" "eval-error")) + (("id" . "1") ("err" . "Divide by zero\n")) + (("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "Divide by zero\nneat> "))) + + (it "shows ex at done when nothing came on err" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("ex" . "boom") ("status" "eval-error")) + (("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "boom\nneat> ") + (expect (get-text-property 1 'face) :to-be 'neat-repl-error))) + + (it "shows ex and done arriving together in one message" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("ex" . "boom") ("status" "eval-error" "done")))) + (expect (neat-repl-test--text) :to-equal "boom\nneat> ")))) + +(describe "neat-repl--render-response (source-buffer evals)" + (it "puts the result above the waiting prompt instead of after it" + (neat-repl-test--with-repl _conn + (neat-repl--insert-prompt) + (neat-repl-test--render-all + '((("id" . "1") ("out" . "hi\n")) + (("id" . "1") ("value" . "3")) + (("id" . "1") ("status" "done"))) + 'source) + (expect (neat-repl-test--text) :to-equal "hi\n3\nneat> "))) + + (it "leaves a single prompt when there's nothing to show" + (neat-repl-test--with-repl _conn + (neat-repl--insert-prompt) + (neat-repl-test--render-all '((("id" . "1") ("status" "done"))) 'source) + (expect (neat-repl-test--text) :to-equal "neat> "))) + + (it "doesn't prompt while input typed into the REPL is still running" + (neat-repl-test--with-repl _conn + (neat-repl--insert-prompt) + ;; What sending input does. + (setq neat-repl--prompt-start nil) + (neat-repl-test--render-all + '((("id" . "2") ("value" . "3")) (("id" . "2") ("status" "done"))) + 'source) + (expect (neat-repl-test--text) :to-equal "neat> 3\n") + (neat-repl-test--render-all '((("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "neat> 3\nneat> ")))) + +(describe "neat-repl--insert-prompt" + (it "doesn't stack a second prompt on one that's waiting" + (neat-repl-test--with-repl _conn + (neat-repl--insert-prompt) + (neat-repl--insert-prompt) + (expect (neat-repl-test--text) :to-equal "neat> "))) + + (it "comes back after clearing the buffer" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-unhandled-message conn '(("out" . "noise\n"))) + (neat-repl-clear-buffer) + (expect (neat-repl-test--text) :to-equal "neat> ") + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (expect (neat-repl-test--text) :to-equal "late\nneat> ")))) + +(describe "neat-repl--render-response (error statuses)" + (it "shows namespace-not-found as a comment line" + ;; Typically a source buffer's `neat-ns' with a typo in it. + (neat-repl-test--with-repl _conn + (neat-repl--insert-prompt) + (neat-repl-test--render-all + '((("id" . "1") ("ns" . "my.typo") + ("status" "done" "error" "namespace-not-found"))) + 'source) + (expect (neat-repl-test--text) + :to-equal ";; namespace not found: my.typo\nneat> "))) + + (it "shows unknown-op as a comment line" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("status" "error" "unknown-op" "done")))) + (expect (neat-repl-test--text) :to-equal ";; unknown op\nneat> "))) + + (it "shows a bare error as a comment line" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all '((("id" . "1") ("status" "error" "done")))) + (expect (neat-repl-test--text) :to-equal ";; error\nneat> "))) + + (it "doesn't add a bare error line after err already explained it" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("err" . "boom\n")) + (("id" . "1") ("status" "error" "done")))) + (expect (neat-repl-test--text) :to-equal "boom\nneat> "))) + + (it "doesn't add a bare error line after an ex" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("ex" . "boom") ("status" "eval-error")) + (("id" . "1") ("status" "error" "done")))) + (expect (neat-repl-test--text) :to-equal "boom\nneat> "))) + + (it "forgets the old session's namespace when it's gone" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "gone" + (neat-connection-ns conn) "myapp.core") + (setq neat-repl--current-ns "myapp.core") + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'y-or-n-p :and-return-value t) + (spy-on 'neat-clone-session) + (neat-repl-test--render-all + '((("id" . "1") ("status" "error" "unknown-session" "done")))) + (expect (neat-connection-ns conn) :to-be nil) + (expect neat-repl--current-ns :to-be nil) + ;; The new prompt doesn't claim the old namespace either. + (expect (neat-repl-test--text) :to-equal ";; unknown session\nneat> "))) + + (it "offers a fresh session on unknown-session" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "gone") + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'y-or-n-p :and-return-value t) + (spy-on 'neat-clone-session) + (neat-repl-test--render-all + '((("id" . "1") ("session" . "gone") + ("status" "error" "unknown-session" "done")))) + (expect (neat-repl-test--text) :to-equal ";; unknown session\nneat> ") + (expect (neat-connection-session conn) :to-be nil) + (expect 'neat-clone-session :to-have-been-called-with conn))) + + (it "drops the dead session even when the offer is declined" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "gone") + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'y-or-n-p :and-return-value nil) + (spy-on 'neat-clone-session) + (neat-repl--render-response + '(("id" . "1") ("status" "error" "unknown-session" "done"))) + (expect (neat-connection-session conn) :to-be nil) + (expect 'neat-clone-session :not :to-have-been-called))) + + (it "asks even when the minibuffer is already in use" + (neat-repl-test--with-repl conn + (let (recursive) + (setf (neat-connection-session conn) "gone") + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'y-or-n-p :and-call-fake + (lambda (&rest _) + (setq recursive enable-recursive-minibuffers) + nil)) + (let ((enable-recursive-minibuffers nil)) + (neat-repl-test--render-all + '((("id" . "1") ("status" "error" "unknown-session" "done"))))) + (expect recursive :to-be-truthy)))) + + (it "takes C-g at the offer as a no" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "gone") + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'y-or-n-p :and-call-fake (lambda (&rest _) (signal 'quit nil))) + (spy-on 'neat-clone-session) + (expect (neat-repl-test--render-all + '((("id" . "1") ("status" "error" "unknown-session" "done")))) + :not :to-throw) + (expect (neat-connection-session conn) :to-be nil) + (expect 'neat-clone-session :not :to-have-been-called))) + + (it "leaves the session alone when the reply names a different one" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "mine") + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'y-or-n-p) + (neat-repl--render-response + '(("id" . "1") ("session" . "other") + ("status" "error" "unknown-session" "done"))) + (expect (neat-connection-session conn) :to-equal "mine") + (expect 'y-or-n-p :not :to-have-been-called)))) + +(describe "neat-repl--render-response (connection-closed)" + (it "inserts a prompt on a normal done" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all '((("id" . "1") ("status" "done")))) + (expect (neat-repl-test--text) :to-equal "neat> "))) + + (it "doesn't prompt for input on the synthesized connection-closed done" + (neat-repl-test--with-repl _conn + (neat-repl-test--render-all + '((("id" . "1") ("status" "done" "connection-closed")))) + (expect (neat-repl-test--text) :to-equal "")))) + +(describe "neat-repl--handle-unhandled-message" + (it "puts late output above the waiting prompt" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (expect (neat-repl-test--text) :to-equal "late\nneat> "))) + + (it "joins chunks that don't end in a newline" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-unhandled-message conn '(("out" . "la"))) + (expect (neat-repl-test--text) :to-equal "la\nneat> ") + (neat-repl--handle-unhandled-message conn '(("out" . "te\n"))) + (expect (neat-repl-test--text) :to-equal "late\nneat> "))) + + (it "leaves half-typed input alone" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (goto-char (point-max)) + (insert "(foo") + (neat-repl--handle-unhandled-message conn '(("err" . "oops\n"))) + (expect (neat-repl-test--text) :to-equal "oops\nneat> (foo") + (expect (get-text-property 1 'face) :to-be 'neat-repl-error) + (expect (point) :to-equal (point-max)))) + + (it "keeps landing above the prompt after an eval finishes" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + ;; What sending input does. + (setq neat-repl--prompt-start nil) + (neat-repl-test--render-all + '((("id" . "1") ("value" . "3")) (("id" . "1") ("status" "done")))) + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (expect (neat-repl-test--text) :to-equal "neat> 3\nlate\nneat> "))) + + (it "streams in at the end while an eval is still running" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (setq neat-repl--prompt-start nil) + (neat-repl--handle-unhandled-message conn '(("out" . "x\n"))) + (expect (neat-repl-test--text) :to-equal "neat> x\n"))) + + (it "runs the text through comint's output filters" + (neat-repl-test--with-repl conn + (let (seen) + (neat-repl--insert-prompt) + (setq-local comint-preoutput-filter-functions (list #'upcase)) + (setq-local comint-output-filter-functions + (list (lambda (_s) + (push (buffer-substring-no-properties + comint-last-output-start + (process-mark (get-buffer-process + (current-buffer)))) + seen)))) + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (expect seen :to-equal '("LATE\n")) + (expect (neat-repl-test--text) :to-equal "LATE\nneat> ") + ;; And the process mark is back after the prompt. + (expect (marker-position (process-mark (get-buffer-process buf))) + :to-equal (point-max))))) + + (it "renders ANSI colors like any other output" + (require 'ansi-color) + (neat-repl-test--with-repl conn + (let ((ansi-color-for-comint-mode t)) + (neat-repl--insert-prompt) + (setq-local comint-output-filter-functions + (list #'ansi-color-process-output)) + (neat-repl--handle-unhandled-message + conn '(("out" . "\e[31mred\e[0m\n"))) + (expect (neat-repl-test--text) :to-equal "red\nneat> ")))) + + (it "applies comint's carriage motion" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-unhandled-message conn '(("out" . "50%\r100%\n"))) + (expect (neat-repl-test--text) :to-equal "100%\nneat> "))) + + (it "works with the buffer narrowed away from the prompt" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (narrow-to-region (point-min) (point-min)) + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (widen) + (expect (neat-repl-test--text) :to-equal "late\nneat> "))) + + (it "leaves the prompt a highlighted, read-only prompt" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-unhandled-message conn '(("out" . "late"))) + (let ((start (marker-position neat-repl--prompt-start))) + (expect (buffer-substring-no-properties start (point-max)) + :to-equal "neat> ") + (expect (marker-position (car comint-last-prompt)) :to-equal start) + (expect (memq 'comint-highlight-prompt + (ensure-list (get-text-property start 'font-lock-face))) + :to-be-truthy) + (expect (get-text-property start 'read-only) :to-be-truthy) + (expect (get-text-property 1 'read-only) :to-be nil)))) + + (it "doesn't trip over a color that streamed output left on" + (require 'ansi-color) + (neat-repl-test--with-repl conn + (let ((ansi-color-for-comint-mode t) + (debug-on-error nil)) + (setq-local comint-output-filter-functions + (list #'ansi-color-process-output)) + (neat-repl--insert-prompt) + ;; An eval from the REPL is running and prints bold, never + ;; switching it off again. + (setq neat-repl--prompt-start nil) + (neat-repl--handle-unhandled-message conn '(("out" . "\e[1mbold\n"))) + (neat-repl--insert-prompt) + (expect (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + :not :to-throw) + (expect (neat-repl--handle-unhandled-message conn '(("out" . "more\n"))) + :not :to-throw) + (expect (neat-repl-test--text) + :to-equal "neat> bold\nlate\nmore\nneat> ")))) + + (it "carries a color across two chunks above the prompt" + (require 'ansi-color) + (neat-repl-test--with-repl conn + (let ((ansi-color-for-comint-mode t)) + (neat-repl--insert-prompt) + (setq-local comint-output-filter-functions + (list #'ansi-color-process-output)) + (neat-repl--handle-unhandled-message conn '(("out" . "\e[31mred\n"))) + (neat-repl--handle-unhandled-message conn '(("out" . "still\e[0m\n"))) + (expect (neat-repl-test--text) :to-equal "red\nstill\nneat> ") + (expect (cl-some (lambda (o) (overlay-get o 'face)) + (overlays-at (+ (point-min) (length "red\n")))) + :to-be-truthy)))) + + (it "overwrites a line that ended in a carriage return" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (dolist (chunk '("10%\r" "20%\r" "30%\r" "done\n")) + (neat-repl--handle-unhandled-message conn `(("out" . ,chunk)))) + (expect (neat-repl-test--text) :to-equal "done\nneat> "))) + + (it "moves point to the input, not onto the prompt" + (neat-repl-test--with-repl conn + (let ((window (selected-window))) + (neat-repl--insert-prompt) + (set-window-buffer window buf) + (setq-local comint-move-point-for-output t) + (goto-char (point-min)) + (set-window-point window (point-min)) + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (expect (window-point window) :to-equal (point-max)) + (expect (with-selected-window window + (insert "x") + (neat-repl-test--text)) + :to-equal "late\nneat> x")))) + + (it "keeps a window that started at the prompt showing the new text" + (neat-repl-test--with-repl conn + (let ((window (selected-window))) + (neat-repl--insert-prompt) + (set-window-buffer window buf) + (set-window-start window (point-min)) + (neat-repl--handle-unhandled-message conn '(("out" . "late\n"))) + (expect (window-start window) :to-equal (point-min))))) + + (it "ignores messages with no output" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-unhandled-message conn '(("status" "done"))) + (expect (neat-repl-test--text) :to-equal "neat> ")))) (describe "neat-repl--handle-need-input" + :var (conn need-input) + (before-each + (setq conn (neat-connection--make :host "h" :port 1 :session "S-conn") + need-input '(("id" . "7") ("session" . "S-eval") + ("status" "need-input")))) + (it "reads input from the minibuffer and sends it via the stdin op" - (let ((conn (neat-connection--make :host "h" :port 1)) - captured) - (cl-letf (((symbol-function 'read-string) - (lambda (&rest _) "world")) - ((symbol-function 'neat-stdin) - (lambda (_c input &rest _) (setq captured input)))) - (neat-repl--handle-need-input conn) - ;; The handler must append a trailing newline so read-line-style - ;; readers actually finish. - (expect captured :to-equal "world\n")))) + (spy-on 'read-from-minibuffer :and-return-value "world") + (spy-on 'neat-stdin) + (neat-repl--handle-need-input conn need-input) + ;; The handler must append a trailing newline so read-line-style + ;; readers actually finish, and answer in the session that asked. + (expect 'neat-stdin + :to-have-been-called-with conn "world\n" :session "S-eval")) + + (it "falls back to the connection's session" + (let (sent) + (spy-on 'read-from-minibuffer :and-return-value "x") + (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) + ((symbol-function 'process-send-string) + (lambda (_p s) (setq sent s)))) + (neat-repl--handle-need-input + conn '(("id" . "7") ("status" "need-input"))) + (expect (neat-bencode-get (car (neat-bencode-decode sent)) "session") + :to-equal "S-conn")))) + + (it "sends an empty stdin as end-of-file" + (spy-on 'read-from-minibuffer + :and-call-fake (lambda (&rest _) + ;; What `neat-repl-stdin-eof' does. + (setq neat-repl--stdin-eof t) + "half a line")) + (spy-on 'neat-stdin) + (neat-repl--handle-need-input conn need-input) + (expect 'neat-stdin :to-have-been-called-with conn "" :session "S-eval")) + + (it "prompts even when the minibuffer is already in use" + (let (recursive) + (spy-on 'read-from-minibuffer + :and-call-fake (lambda (&rest _) + (setq recursive enable-recursive-minibuffers) + "x")) + (spy-on 'neat-stdin) + (let ((enable-recursive-minibuffers nil)) + (neat-repl--handle-need-input conn need-input)) + (expect recursive :to-be-truthy))) + + (it "binds the end-of-file key in the prompt's keymap" + (expect (lookup-key neat-repl-stdin-map (kbd "C-c C-d")) + :to-be 'neat-repl-stdin-eof)) (it "interrupts the eval when the user hits C-g at the prompt" - (let ((conn (neat-connection--make :host "h" :port 1)) - interrupted) - (cl-letf (((symbol-function 'read-string) - (lambda (&rest _) (signal 'quit nil))) - ((symbol-function 'neat-interrupt) - (lambda (c &rest _) (setq interrupted c))) - ((symbol-function 'neat-stdin) - (lambda (&rest _) (error "should not send stdin")))) - (neat-repl--handle-need-input conn) - (expect interrupted :to-be conn))))) + (spy-on 'read-from-minibuffer :and-call-fake + (lambda (&rest _) (signal 'quit nil))) + (spy-on 'neat-interrupt) + (spy-on 'neat-stdin) + (neat-repl--handle-need-input conn need-input) + (expect (butlast (spy-calls-args-for 'neat-interrupt 0)) + :to-equal (list conn "S-eval" "7")) + (expect 'neat-stdin :not :to-have-been-called)) + + (it "reports an interrupt from the prompt that didn't happen" + (spy-on 'read-from-minibuffer :and-call-fake + (lambda (&rest _) (signal 'quit nil))) + (spy-on 'neat-interrupt + :and-call-fake (lambda (_c _s _id cb) + (funcall cb '(("id" . "9") + ("status" "interrupt-id-mismatch" + "done"))))) + (spy-on 'message) + (neat-repl--handle-need-input conn need-input) + (expect 'message :to-have-been-called-with + "Neat: that eval isn't the one running")) + + (it "sends end-of-file on C-g when the server can't interrupt" + (setf (neat-connection-capabilities conn) '(("ops" . (("eval") ("stdin"))))) + (spy-on 'read-from-minibuffer :and-call-fake + (lambda (&rest _) (signal 'quit nil))) + (spy-on 'neat-interrupt) + (spy-on 'neat-stdin) + (neat-repl--handle-need-input conn need-input) + (expect 'neat-interrupt :not :to-have-been-called) + (expect 'neat-stdin :to-have-been-called-with conn "" :session "S-eval"))) + +(describe "neat-repl--render-response (need-input)" + (it "hands need-input to the stdin prompt, with the response" + (neat-repl-test--with-repl conn + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'neat-repl--handle-need-input) + (let ((resp '(("id" . "1") ("session" . "S") ("status" "need-input")))) + (neat-repl--render-response resp) + (expect 'neat-repl--handle-need-input + :to-have-been-called-with conn resp) + ;; Still waiting on the eval, so no prompt yet. + (expect (neat-repl-test--text) :to-equal ""))))) + +(describe "closing the REPL" + :var (calls) + (before-each + (setq calls nil) + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'neat-close-session-sync + :and-call-fake (lambda (c &rest _) + (push (list 'close (neat-connection-session c)) + calls))) + (spy-on 'neat-close-session + :and-call-fake (lambda (c &rest _) + (push (list 'close-no-wait + (neat-connection-session c)) + calls))) + (spy-on 'neat-disconnect + :and-call-fake (lambda (_c) (push 'disconnect calls)))) + + (it "closes the session before disconnecting on quit" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "S-1") + (spy-on 'bury-buffer) + (neat-repl-quit) + (expect (nreverse calls) :to-equal '((close "S-1") disconnect)) + (expect neat-current-connection :to-be nil))) + + (it "closes the session without waiting when the buffer is killed" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "S-2") + (neat-repl--kill-buffer-cleanup) + (expect (nreverse calls) :to-equal '((close-no-wait "S-2") disconnect)))) + + (it "still disconnects when the close wait is quit out of" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "S-4") + (spy-on 'neat-close-session-sync + :and-call-fake (lambda (&rest _) (signal 'quit nil))) + (condition-case nil + (neat-repl--close-connection conn) + (quit nil)) + (expect calls :to-equal '(disconnect)))) + + (it "just disconnects when there's no session to close" + (neat-repl-test--with-repl _conn + (spy-on 'bury-buffer) + (neat-repl-quit) + (expect calls :to-equal '(disconnect)))) + + (it "just disconnects when the server doesn't support close" + (neat-repl-test--with-repl conn + (setf (neat-connection-session conn) "S-3" + (neat-connection-capabilities conn) '(("ops" "eval" "clone"))) + (spy-on 'bury-buffer) + (neat-repl-quit) + (expect calls :to-equal '(disconnect))))) (describe "neat-repl--handle-disconnect" (it "sets the dead flag on the conn's REPL buffer" @@ -130,6 +736,23 @@ :to-be-truthy)) (kill-buffer buf)))) + (it "lets a reconnect in the same buffer start on a fresh line" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-disconnect conn) + ;; What `neat' does with a buffer that's still around. + (neat-repl-create-buffer conn) + (neat-repl--insert-prompt) + (expect (neat-repl-test--text) + :to-equal ";; connection closed\nneat> \nneat> "))) + + (it "puts the marker above a waiting prompt" + (neat-repl-test--with-repl conn + (neat-repl--insert-prompt) + (neat-repl--handle-disconnect conn) + (expect (neat-repl-test--text) + :to-equal ";; connection closed\nneat> "))) + (it "is a no-op when no REPL buffer exists for the connection" (let ((conn (neat-connection--make :host "h" :port 999999))) (expect (neat-repl--handle-disconnect conn) :not :to-throw)))) diff --git a/test/neat-test.el b/test/neat-test.el index 55c4715..f70927c 100644 --- a/test/neat-test.el +++ b/test/neat-test.el @@ -179,6 +179,338 @@ POS is a 1-indexed buffer position." (lambda () (neat--eval-string "(+ 1 2)"))))) (expect (plist-get plist :ns) :to-equal "derived.ns")))))) +(describe "neat--eval-callback without a REPL buffer" + (it "reports a connection that closed under the request" + (let ((conn (neat-connection--make :host "nowhere" :port 1))) + (spy-on 'message) + (funcall (neat--eval-callback conn) + '(("id" . "1") ("status" "done" "connection-closed"))) + (expect 'message :to-have-been-called-with + "neat: connection closed"))) + + (it "doesn't follow an err with a bare error" + (let* ((conn (neat-connection--make :host "nowhere" :port 1)) + (callback (neat--eval-callback conn))) + (spy-on 'message) + (funcall callback '(("id" . "1") ("err" . "boom\n"))) + (funcall callback '(("id" . "1") ("status" "error" "done"))) + (expect 'message :to-have-been-called-with "neat: %s" "boom") + (expect 'message :not :to-have-been-called-with "neat: %s" "error"))) + + (it "shows an ex when nothing came on err" + (let* ((conn (neat-connection--make :host "nowhere" :port 1)) + (callback (neat--eval-callback conn))) + (spy-on 'message) + (funcall callback '(("id" . "1") ("ex" . "boom") ("status" "eval-error"))) + (funcall callback '(("id" . "1") ("status" "error" "done"))) + (expect 'message :to-have-been-called-with "neat: %s" "boom") + (expect 'message :not :to-have-been-called-with "neat: %s" "error"))) + + (it "prompts in the minibuffer when the eval needs input" + (let ((conn (neat-connection--make :host "nowhere" :port 1)) + (resp '(("id" . "1") ("session" . "S") ("status" "need-input")))) + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'neat-repl--handle-need-input) + (funcall (neat--eval-callback conn) resp) + (expect 'neat-repl--handle-need-input + :to-have-been-called-with conn resp))) + + (it "reports an error status in the echo area" + (let ((conn (neat-connection--make :host "nowhere" :port 1))) + (spy-on 'message) + (funcall (neat--eval-callback conn) + '(("id" . "1") ("ns" . "my.typo") + ("status" "done" "error" "namespace-not-found"))) + (expect 'message :to-have-been-called-with + "neat: %s" "namespace not found: my.typo")))) + +(describe "neat" + :var (conn clone-callback) + (before-each + (setq conn (neat-connection--make :host "h" :port 77) + clone-callback nil) + (spy-on 'neat-connect :and-return-value conn) + (spy-on 'neat-describe) + (spy-on 'neat-clone-session + :and-call-fake (lambda (_c cb) (setq clone-callback cb))) + (spy-on 'pop-to-buffer)) + + (after-each + (when-let* ((buf (neat-repl-buffer-for conn))) + (kill-buffer buf))) + + (it "puts up the first prompt once the session is cloned" + (let ((neat-repl-history-file nil) + (neat-default-connection nil)) + (neat "h" 77) + (funcall clone-callback '(("id" . "2") ("new-session" . "S") + ("status" "done"))) + (with-current-buffer (neat-repl-buffer-for conn) + (expect (buffer-string) :to-equal "neat> ")))) + + (it "doesn't put up a prompt when the connection closes first" + (let ((neat-repl-history-file nil) + (neat-default-connection nil)) + (neat "h" 77) + (funcall clone-callback '(("id" . "2") + ("status" "done" "connection-closed"))) + (with-current-buffer (neat-repl-buffer-for conn) + (expect (buffer-string) :to-equal ""))))) + +(describe "source-buffer evals and the REPL's ns" + (it "moves the prompt only when the buffer named no ns" + (let* ((neat-repl-history-file nil) + (conn (neat-connection--make :host "h" :port 78)) + (repl (neat-repl-create-buffer conn)) + callback) + (unwind-protect + (cl-letf (((symbol-function 'neat--require-connection) + (lambda () conn)) + ((symbol-function 'neat-eval) + (lambda (_c _code &rest plist) + (setq callback (plist-get plist :callback))))) + (with-temp-buffer + (setq neat-ns "my.ns") + (neat--eval-string "(+ 1 2)")) + (funcall callback '(("id" . "1") ("ns" . "my.ns") ("value" . "3"))) + (expect (buffer-local-value 'neat-repl--current-ns repl) + :to-be nil) + (with-temp-buffer + (neat--eval-string "(ns myapp.core)")) + (funcall callback '(("id" . "2") ("ns" . "myapp.core") + ("value" . "nil"))) + (expect (buffer-local-value 'neat-repl--current-ns repl) + :to-equal "myapp.core")) + (with-current-buffer repl (setq neat-current-connection nil)) + (kill-buffer repl))))) + +(describe "neat--tooling-ns" + (it "prefers the buffer's ns" + (with-temp-buffer + (setq neat-ns "my.ns") + (let ((conn (neat-connection--make :ns "user"))) + (expect (neat--tooling-ns conn) :to-equal "my.ns")))) + + (it "falls back to the ns the REPL last reported" + (with-temp-buffer + (let ((conn (neat-connection--make :ns "user"))) + (expect (neat--tooling-ns conn) :to-equal "user")))) + + (it "is nil when neither knows" + (with-temp-buffer + (expect (neat--tooling-ns (neat-connection--make)) :to-be nil)))) + +(describe "tooling ops send an ns" + :var (conn) + (before-each + (setq conn (neat-connection--make :host "h" :port 1 :ns "user")) + (spy-on 'neat-active-connection :and-return-value conn) + (spy-on 'neat-connection-live-p :and-return-value t)) + + (it "in completion-at-point" + (spy-on 'neat-completions-sync :and-return-value nil) + (with-temp-buffer + (insert "ma") + (neat-completion-at-point) + (expect 'neat-completions-sync + :to-have-been-called-with conn "ma" "user" + neat-completion-timeout))) + + (it "in eldoc" + (spy-on 'neat-lookup) + (with-temp-buffer + (insert "(map ") + (neat-eldoc-function #'ignore) + (expect (nth 2 (spy-calls-args-for 'neat-lookup 0)) :to-equal "user"))) + + (it "in eldoc, trying again without it when it's turned down" + (let (shown) + (spy-on 'neat-lookup + :and-call-fake + (lambda (_c _sym ns cb) + (funcall cb (if ns + '(("id" . "1") + ("status" "done" "error" "namespace-not-found")) + '(("id" . "2") ("info" . (("doc" . "Maps."))) + ("status" "done")))))) + (with-temp-buffer + (insert "(map ") + (neat-eldoc-function (lambda (str &rest _) (setq shown str)))) + (expect (mapcar (lambda (args) (nth 2 args)) + (reverse (spy-calls-all-args 'neat-lookup))) + :to-equal '("user" nil)) + (expect shown :to-equal "Maps."))) + + (it "in the doc lookup" + (spy-on 'neat-lookup-sync :and-return-value '(("name" . "map"))) + (spy-on 'neat--render-doc) + (with-temp-buffer + (insert "map") + (neat-show-doc-at-point) + (expect 'neat-lookup-sync + :to-have-been-called-with conn "map" "user" neat-lookup-timeout))) + + (it "in xref find-definitions" + (spy-on 'neat-lookup-sync :and-return-value nil) + (with-temp-buffer + (xref-backend-definitions 'neat "map") + (expect 'neat-lookup-sync + :to-have-been-called-with conn "map" "user" + neat-lookup-timeout)))) + +(describe "neat-eldoc-function" + (it "tells eldoc when there's nothing to show" + (let ((conn (neat-connection--make :host "h" :port 1)) + (calls nil)) + (spy-on 'neat-active-connection :and-return-value conn) + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'neat-lookup-async + :and-call-fake (lambda (_c _sym _ns _timeout cb) (funcall cb nil))) + (with-temp-buffer + (insert "(map ") + (neat-eldoc-function (lambda (&rest args) (push args calls)))) + (expect calls :to-equal '((nil)))))) + +(describe "features gated on describe" + :var (conn) + (before-each + ;; A server that advertises only eval, like Basilisp does for the + ;; tooling ops. + (setq conn (neat-connection--make + :host "h" :port 1 + :capabilities '(("ops" . (("eval") ("clone")))))) + (spy-on 'neat-active-connection :and-return-value conn) + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'neat-completions-sync) + (spy-on 'neat-lookup-sync) + (spy-on 'neat-lookup) + (spy-on 'neat-interrupt)) + + (it "keeps completion-at-point quiet without completions" + (with-temp-buffer + (insert "ma") + (expect (neat-completion-at-point) :to-be nil) + (expect 'neat-completions-sync :not :to-have-been-called))) + + (it "keeps eldoc quiet without lookup" + (with-temp-buffer + (insert "(map ") + (expect (neat-eldoc-function #'ignore) :to-be nil) + (expect 'neat-lookup :not :to-have-been-called))) + + (it "steps the xref backend aside without lookup" + (with-temp-buffer + (expect (neat--xref-backend) :to-be nil))) + + (it "tells the user the doc lookup isn't supported" + (with-temp-buffer + (insert "map") + (expect (neat-show-doc-at-point) :to-throw 'user-error) + (expect 'neat-lookup-sync :not :to-have-been-called))) + + (it "tells the user interrupt isn't supported" + (expect (neat-interrupt-eval) :to-throw 'user-error) + (expect 'neat-interrupt :not :to-have-been-called))) + +(describe "tooling while an eval is in flight" + :var (conn) + (before-each + (setq conn (neat-connection--make :host "h" :port 1 :evals '("5"))) + (spy-on 'neat-active-connection :and-return-value conn) + (spy-on 'neat-connection-live-p :and-return-value t) + (spy-on 'neat-completions-sync) + (spy-on 'neat-lookup)) + + (it "goes ahead while the server keeps answering" + ;; nREPL answers tooling ops mid-eval, so nothing gets held back. + (with-temp-buffer + (insert "ma") + (neat-completion-at-point) + (expect 'neat-completions-sync :to-have-been-called))) + + (it "skips completion-at-point once requests stall" + (setf (neat-connection-stalled conn) (float-time)) + (with-temp-buffer + (insert "ma") + (expect (neat-completion-at-point) :to-be nil) + (expect 'neat-completions-sync :not :to-have-been-called))) + + (it "keeps eldoc to one lookup in flight" + (let (pending-callback) + (spy-on 'neat-lookup-async + :and-call-fake (lambda (_c _sym _ns _timeout cb) + (setq pending-callback cb))) + (with-temp-buffer + (insert "(map ") + (expect (neat-eldoc-function #'ignore) :to-be-truthy) + (expect (neat-eldoc-function #'ignore) :to-be nil) + (expect 'neat-lookup-async :to-have-been-called-times 1) + ;; Once the first one is answered the next can go. + (funcall pending-callback nil) + (expect (neat-eldoc-function #'ignore) :to-be-truthy) + (expect 'neat-lookup-async :to-have-been-called-times 2) + (funcall pending-callback nil)))) + + (it "doesn't leave eldoc stuck when the ns or the send fails" + (with-temp-buffer + (insert "(map ") + (let ((neat-buffer-ns-function (lambda () (error "No ns here")))) + (expect (neat-eldoc-function #'ignore) :to-throw 'error)) + (expect (gethash conn neat--eldoc-in-flight) :to-be nil) + (spy-on 'neat-lookup-async + :and-call-fake (lambda (&rest _) (error "Can't send"))) + (expect (neat-eldoc-function #'ignore) :to-throw 'error) + (expect (gethash conn neat--eldoc-in-flight) :to-be nil))) + + (it "skips eldoc once requests stall" + (setf (neat-connection-stalled conn) (float-time)) + (with-temp-buffer + (insert "(map ") + (expect (neat-eldoc-function #'ignore) :to-be nil) + (expect 'neat-lookup :not :to-have-been-called)))) + +(describe "neat-interrupt-eval" + :var (conn callback) + (before-each + (setq conn (neat-connection--make :host "h" :port 1)) + (spy-on 'neat-active-connection :and-return-value conn) + (spy-on 'neat-interrupt + :and-call-fake (lambda (_c _s _id cb) (setq callback cb))) + (spy-on 'message)) + + (it "says so when there was nothing to interrupt" + (neat-interrupt-eval) + (funcall callback '(("id" . "2") ("status" "session-idle" "done"))) + (expect 'message :to-have-been-called-with "Neat: nothing to interrupt")) + + (it "says so when there's no session to interrupt in" + (neat-interrupt-eval) + (funcall callback '(("id" . "2") ("status" "session-ephemeral" "done"))) + (expect 'message :to-have-been-called-with + "Neat: can't interrupt an eval with no session")) + + (it "says so when the eval named isn't the one running" + (neat-interrupt-eval) + (funcall callback '(("id" . "2") ("status" "interrupt-id-mismatch" "done"))) + (expect 'message :to-have-been-called-with + "Neat: that eval isn't the one running")) + + (it "says so when the interrupt fails some other way" + (neat-interrupt-eval) + (funcall callback '(("id" . "2") ("status" "error" "done"))) + (expect 'message :to-have-been-called-with "Neat: the interrupt failed")) + + (it "stays quiet when the interrupt goes through" + (neat-interrupt-eval) + (funcall callback '(("id" . "2") ("status" "done"))) + (expect 'message :not :to-have-been-called)) + + (it "says so when the server turns out not to know the op" + (neat-interrupt-eval) + (funcall callback '(("id" . "2") ("status" "error" "unknown-op" "done"))) + (expect 'message :to-have-been-called-with + "Neat: the server doesn't support interrupt"))) + (describe "neat--lookup-file-path" (it "returns plain paths unchanged" (expect (neat--lookup-file-path "/tmp/foo.clj")