From f4725788c5b0291ca0e199a5a3d39440ee5fdb80 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:16:49 +0700 Subject: [PATCH 1/2] The daemon pushes the program's output and the watch table to an editor that asked for them, and every key a Flan buffer's own map binds is that buffer's under Evil --- TODO.org | 29 +++-- docs/BUILT.md | 72 ++++++++--- emacs/MANUAL.md | 17 +-- emacs/flan-cnr.el | 20 +-- emacs/flan-inspect.el | 3 + emacs/flan-lower.el | 2 + emacs/flan-mode.el | 33 +++++ emacs/flan-watch.el | 208 +++++++++++++----------------- emacs/flan.el | 265 ++++++++++++++++++++++++--------------- emacs/test-flan-cider.el | 34 ++++- emacs/test-flan-watch.el | 103 ++++++++------- emacs/test-flan.el | 181 ++++++++++++++------------ lib/dev.ml | 166 ++++++++++++++++++++++++ test/test_dev.ml | 23 ++++ 14 files changed, 759 insertions(+), 397 deletions(-) diff --git a/TODO.org b/TODO.org index a76e8535..e2c7d540 100644 --- a/TODO.org +++ b/TODO.org @@ -1874,13 +1874,15 @@ Open: what migration does with a stored value that no longer fits a changed slot type, and whether an untyped slot stays legal (it should — =dyn= is a type and writing nothing should mean it). -** NEXT println takes up to a second to appear -Decided 2026-09-25: the daemon pushes program output on the editor's connection as it is written. Rules out a faster poll. -Output is drained by =flan--poll= at =flan-poll-interval=, 1.0s -(=emacs/flan.el:541=). A reply carries whatever was buffered when it was -composed, so anything the program prints after that waits for the next tick. -Polling faster costs a request a second for nothing most of the time; the -daemon pushing on its own connection is the other shape. Decide which. +** DONE println takes up to a second to appear +CLOSED: [2026-09-25] +The daemon pushes program output on a connection that asked for pushes +(=(:op "push" :on t)=), coalesced to at most one frame per 50ms, and the +watch table on the same channel at =flan-watch-interval=. Emacs reads every +frame in a process filter. The editor's watch timer and =flan-settle-hook= +are gone. The poll stays for the stop and park edges. Rules out a faster +poll and pushes to clients that did not ask for them. See docs/BUILT.md, +"Output and the watch table are pushed". ** NEXT set writes a class slot; put is for maps Decided 2026-09-25: as written; one lane with typed slots. @@ -1931,11 +1933,14 @@ motion states in that mode; every other key, including what =special-mode-map= binds, stays Evil's. The other special-mode buffers (inspect, watch, doc, disassembly, diagnostics, lower) have the same exposure and are not changed. -** NEXT Evil takes the keys in the other Flan buffers -The inspect, watch, doc, disassembly, diagnostics and lower buffers get the break -buffer's treatment: the keys each binds itself go to Evil's normal and motion -states, and every other key stays Evil's. Bindings stay as close as possible -between Evil and Emacs states. +** DONE Evil takes the keys in the other Flan buffers +CLOSED: [2026-09-25] +=flan-evil-own-keys= (flan-mode.el) gives the keys a mode's own map binds to +Evil's normal and motion states; the break, inspect, watch, doc, disassembly, +diagnostics and lower buffers all call it. The doc, disassembly and watch +maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are +the mode's own and behave the same under Evil. Every key a mode does not bind +itself, including the rest of =special-mode-map=, stays Evil's. ** NEXT Eval in the frame, from the break loop Decided 2026-09-25: SLIME's eval-in-frame, as described. diff --git a/docs/BUILT.md b/docs/BUILT.md index 930c83da..b6cfdc14 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -2225,8 +2225,8 @@ So the state is learned **twice, deliberately**: or `:stopped nil`. The likeliest instant for a program to stop is the one just after an evaluation — a body that now errors — and that is a reply the client is already reading. Finding out a second later from a poll would mean finding out *after* the echo area had said the evaluation was fine. -- **And a timer asks anyway**, once a second, with `describe` — the cheap op, which is also how the output pipe is -drained. A program that stops in a frame of its own game loop produces no reply at all, and folding state into replies +- **And a timer asks anyway**, once a second, with `describe` — the cheap op. (It used to be how the program's output +reached the editor as well; output is pushed now, below.) A program that stops in a frame of its own game loop produces no reply at all, and folding state into replies that never come says nothing. The timer never *reconnects*: `flan--request` reopens a socket a restarted daemon left behind, which is right for something a person did and wrong for a background poll, because it would quietly erase the `lost` state that exists to be seen. It also skips while another request is in flight — `accept-process-output` runs @@ -2279,6 +2279,50 @@ state an editor has to cope with and the hardest one to arrange later. The Emacs round, by installing a `step` that errors into a loop that calls it, fixes it while stopped, and then resumes: `C-x C-e` answering while the program sits in the break loop is checked there against the real client, not only in OCaml. +### Output and the watch table are pushed + +A `println` used to reach Emacs on the next reply, and when nobody was evaluating, the next reply was the one-second +poll's. Polling faster pays a request a second for nothing most of the time, so the daemon writes to the editor's +connection unasked instead. + +`(:op "push" :on t)` turns it on for the connection that sends it; `flan--open` sends it on every connect. From then +on `serve` waits in `select` on the connection, the program's stdout pipe, and the next push's deadline, and sends two +kinds of frame without being asked: + +``` +(:push "output" :status "ok" :output "HELLO\n") +(:push "watch" :status "ok" :watch (("ticks" "412")) :overflow nil) +``` + +**Opt-in, because a client that does not know about pushes would read one as its reply.** `test_dev.ml` and every +other raw-socket client keep the one-reply-per-request protocol and never see a push frame. + +**Output is coalesced on the daemon side.** The first bytes after a quiet spell wait 10ms for more, and no two output +pushes are closer than 50ms. A program printing every frame is twenty frames a second on the socket, not sixty or two +hundred, and a single line still arrives within 50ms. `capacity` still bounds what is buffered. + +**A push never lands inside a reply.** `serve` is one thread, so nothing is pushed while a request is handled; what +the program prints meanwhile stays in `t.out`, `with_output` puts it on that request's reply and empties the buffer, +and it is not pushed a second time. The stdout pipe is also drained now while an editor sits idle, which it was not: +`Wire.recv` blocked, so an attached, quiet editor let the pipe fill until its next request. A push goes out only when +the socket is writable; an editor that has stopped reading holds pushes back rather than stalling the loop, and its +output waits in `t.out`. + +**The watch table moved onto the same channel.** `watch-enable` with `:interval` arms a push of the table from the +same loop, sent every interval whether or not it changed, because ghost text is repainted from each one. The editor's watch timer, its in-flight flag and +`flan-settle-hook` — which existed only so the timer's unawaited reply could not be read by another request — are +gone, because nothing in Emacs sends without waiting any more. Whether a push resets the numeric window is decided +where the table is read: not while the program is stopped (see the accumulator section below). + +**In Emacs a process filter reads every frame as it arrives.** A push is handled there — output into the daemon's +buffer and the REPL, the watch table through `flan-push-functions` — and a reply is queued on the process for +`flan--read-reply`. A reply at the head of the buffer with a push behind it is the case that needs the queue: leaving +replies in the buffer for the reader would hold the push behind them until the next request. A frame is recognised as +a push by its text beginning `(:push `, before it is read, so an unreadable push is dropped with a message rather than +queued as some request's error. + +The poll stays, for the stop and park edges. + ### `layout` — a type's fields, with no program involved ``` @@ -6029,11 +6073,10 @@ name in the table came from one of these call sites by construction — and the `syntax-ppss`) is what stops a call *written inside a string* being taken for one. **One reply, two pictures.** Ghost text does not poll. It is painted from `flan-watch--absorb`, the same function -that paints the buffer, from the same reply, so the two cannot disagree and there is no second `:op "watch"` in -flight — the one-request invariant `flan-settle-hook` exists to keep. What had to change is that the **watch -buffer used to be the subscription**: killing it cancelled the timer and disarmed the table. That was right while it -was the only consumer and wrong the moment it was not, so arming and the timer now hang off -`flan-watch--consumers`, and only the last consumer out turns the lights off. +that paints the buffer, from the same push, so the two cannot disagree. What had to change is that the **watch +buffer used to be the subscription**: killing it disarmed the table. That was right while it was the only consumer and +wrong the moment it was not, so arming hangs off `flan-watch--consumers`, and only the last consumer out turns the +lights off. **Overlays are replaced wholesale on every repaint**, never followed through edits. That is the entire answer to the invalidation problem the earlier note called the work: a line that moved cannot strand an overlay, because no overlay @@ -6113,9 +6156,10 @@ the counter check. cumulative until `reset-spies!` is called by hand. Cumulative is the wrong default for a frame loop: a `min` and a `max` over a whole session reach the session's extremes within a few seconds of play and then never move again, so the two most useful of the five go dead exactly when you start interacting with the thing you are debugging. This -tool exists to show you a number while you drag the mouse. So `flan-watch--tick` sends `:reset t` beside its read and -the displayed range is "since you last looked" — a fifth of a second, a dozen frames. A caller that wants the -cumulative numbers gets them by not resetting; the setting lives in the editor, not in the runtime. +tool exists to show you a number while you drag the mouse. So each push of the table resets after its read and the +displayed range is "since you last looked" — a fifth of a second, a dozen frames. A caller of the `watch` op that +wants the cumulative numbers gets them by not passing `:reset t`; the policy lives in the daemon's push, not in the +runtime. **Reset is its own message, and it is not a side effect of reading.** A destructive read was the tempting shape and is wrong: it makes *looking* change what is there, so anything that polls — a test's `await`, a second editor, a @@ -6137,10 +6181,10 @@ empty — which would make a reset visible in the very next tick instead of in t sample. It is the wrong trade, because **a stopped program does not sample**. An epoch-aware reader would blank the watch for as long as the program sat in a break loop, and reading the numbers from the moment you stopped is the entire point of stopping. The lazy clear gives exactly the right answer there. What was actually wrong was narrower -and lives in the editor: `flan-watch--tick` was sending `:reset t` five times a second at a program that could not -answer it. So the reset is now guarded on `flan--stopped` — the read still goes out every tick, only the reset -field drops — and the runtime is untouched. That keeps the policy where the rest of this section already put it: -"since you last looked" is the editor's idea, not the table's. `watch_render_num`'s unreachable `n=0` arm is deleted +and was a reset sent five times a second at a program that could not answer it. So the reset is guarded on the +program being stopped — the table is still read and pushed, only the reset is skipped — and the runtime is untouched. +The guard was the editor's while the editor polled the table; it is `push_due`'s in `dev.ml` now that the daemon +pushes it, asked of the program with `status` at each push. `watch_render_num`'s unreachable `n=0` arm is deleted rather than commented, since the only way to reach it is the epoch check that was just rejected, and dead code is an invitation to add one. diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index ad0def76..ee17eb02 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -291,8 +291,10 @@ that is what the program calls it. form rides along on the reply and is inserted above the prompt — output first, then the value, the way a terminal REPL reads. When a compile fails the prompt gets one line, `1 error — see *flan-diagnostics*`, and the message -itself is in that buffer, which pops up. The daemon's buffer `*flan*` mirrors -all program output, so a println is never lost when no prompt is open. +itself is in that buffer, which pops up. What the program prints on its own, +between evaluations, is sent by the daemon as it is printed and appears at +once. The daemon's buffer `*flan*` mirrors all program output, so a println is +never lost when no prompt is open. **Two clears.** `C-c C-o` removes what the last send produced — output, value or error line — and leaves the transcript. `C-c M-o` erases the transcript @@ -744,9 +746,9 @@ The slot renders as `n=… min=… max=… last=… mean=…`, one line per Two entry points rather than one so a program need not cast at the call site. The write path does **no formatting** — a sample is a load, five compares and -the slot's seqlock — and the listener thread renders once per editor tick, which +the slot's seqlock — and the listener thread renders once per repaint, which is the whole reason this exists rather than a second `watch-i64`. **The window is -since the editor's last tick**, not since the program started: a min and a max +since the last repaint**, not since the program started: a min and a max over a whole session reach the session's extremes within seconds and then never move again, so the two most useful of the five would go dead exactly when you start playing. A whole number prints as one, because a spy on an array index @@ -792,11 +794,12 @@ your own entry points to names that do not start with `watch`, set `flan-watch-ghost-call-regexp` — the Flan name is yours, and only the C symbol behind it is fixed. -**When it updates.** On the same timer as the buffer, from the same reply, so -the two cannot disagree. As with the buffer, the interval decides how often the +**When it updates.** Each time the daemon sends the table, from the same frame +as the buffer, so the two cannot disagree. As with the buffer, the interval decides how often the picture is repainted and not how fresh it is. Overlays are replaced wholesale each repaint rather than followed through your edits, so a line you moved never -leaves one stranded, and a file you scroll to gets its values within a tick. +leaves one stranded, and a file you scroll to gets its values at the next +repaint. Only buffers **shown in a window** are scanned, which is what keeps that cheap. **One name, two call sites.** Both show it, and both say `one slot, 2 sites`. diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 5bc4e1f7..88973929 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -64,6 +64,7 @@ (require 'seq) (require 'subr-x) +(require 'flan-mode) (declare-function flan--request "flan" (form)) (declare-function flan-visit-loc "flan" (loc subject)) @@ -832,22 +833,9 @@ anyone who would rather TAB always moved." "Keys in `flan-cnr-mode'.") ;; Evil's normal state binds 0, the other digits and RET above any major -;; mode's map, so under Evil a digit moved point or started a count and took -;; nothing. The keys this file binds are given to Evil's normal and motion -;; states in this mode. Only those keys: `flan-cnr-mode-map' inherits -;; `special-mode-map', and making it an overriding map would carry h, SPC, < -;; and - over from there as well. Every key not listed stays Evil's. -(with-eval-after-load 'evil - (when (fboundp 'evil-define-key*) - ;; Collected first, and without the parent's bindings, because - ;; `evil-define-key*' writes into the map being walked. - (let ((own nil)) - (map-keymap-internal (lambda (key def) - (when (commandp def) (push (cons key def) own))) - flan-cnr-mode-map) - (dolist (b own) - (evil-define-key* '(normal motion) flan-cnr-mode-map - (vector (car b)) (cdr b)))))) +;; mode's map, so under Evil a digit would move point or start a count and +;; take nothing. See `flan-evil-own-keys'. +(flan-evil-own-keys 'flan-cnr-mode-map) (define-derived-mode flan-cnr-mode special-mode "flan-break" "What a stopped Flan program is offering." diff --git a/emacs/flan-inspect.el b/emacs/flan-inspect.el index 32ab9302..72cc68a4 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -99,6 +99,7 @@ (require 'cl-lib) (require 'seq) (require 'subr-x) +(require 'flan-mode) (declare-function flan--request "flan" (form)) @@ -1280,6 +1281,8 @@ the kind of thing nobody reports and everybody notices." map) "Keys in `flan-inspect-mode'.") +(flan-evil-own-keys 'flan-inspect-mode-map) + (define-derived-mode flan-inspect-mode special-mode "flan-inspect" "Look at a value in the running Flan program." (setq buffer-read-only t) diff --git a/emacs/flan-lower.el b/emacs/flan-lower.el index 6dac6d37..2627d607 100644 --- a/emacs/flan-lower.el +++ b/emacs/flan-lower.el @@ -571,6 +571,8 @@ that is felt." map) "Keys in `flan-lower-mode'.") +(flan-evil-own-keys 'flan-lower-mode-map) + (define-derived-mode flan-lower-mode special-mode "flan-lower" "Every lowering of one Flan function, in foldable sections. diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 3a78cbfa..0930b325 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -776,5 +776,38 @@ decision to `calculate-lisp-indent'." ;;;###autoload (add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode)) +;;; The other Flan buffers under Evil + +;; Evil's normal state binds most single keys — the digits, RET, TAB, n, p, q, +;; g — above any major mode's map, so in a buffer of Flan's own a key its mode +;; binds would move point, start a count or record a macro instead. Each such +;; buffer's mode gives the keys its own map binds to Evil's normal and motion +;; states, so they do the same thing under Evil as without it. Only those +;; keys: the maps inherit `special-mode-map', and making one an overriding map +;; would carry h, SPC, < and - over from there as well. Every key a mode does +;; not bind itself stays Evil's. + +(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings)) + +(defun flan-evil-own-keys (name) + "Give the keys the map named NAME binds itself to Evil's states. +Normal and motion. Takes effect when Evil is loaded, or at once if it +already is. + +The map is passed by name because `eval-after-load' drops a function +`equal' to one it already holds, and two maps with the same bindings are +`equal': given the maps, only the first of them would be set up." + (with-eval-after-load 'evil + (when (fboundp 'evil-define-key*) + ;; Collected first, and without the parent's bindings, because + ;; `evil-define-key*' writes into the map being walked. + (let ((map (symbol-value name)) + (own nil)) + (map-keymap-internal (lambda (key def) + (when (commandp def) (push (cons key def) own))) + map) + (dolist (b own) + (evil-define-key* '(normal motion) map (vector (car b)) (cdr b))))))) + (provide 'flan-mode) ;;; flan-mode.el ends here diff --git a/emacs/flan-watch.el b/emacs/flan-watch.el index 3b013653..66db28eb 100644 --- a/emacs/flan-watch.el +++ b/emacs/flan-watch.el @@ -47,20 +47,20 @@ ;; halves are cheap for opposite reasons, and two things fall out that a poll ;; could not have given: ;; -;; the values update at *frame rate* rather than at the timer's rate — the -;; timer only decides how often the picture is repainted, not how fresh it -;; is; +;; the values update at *frame rate* rather than at the repaint rate — the +;; interval only decides how often the picture is repainted, not how fresh +;; it is; ;; ;; and the last frame's values are still there while the program is ;; *stopped*. A break loop is precisely when no thunk can run at a frame ;; boundary, because there are no more frames, and precisely when you want to ;; see what the last one held. ;; -;; Also kept from the original, and for its stated reasons: the request is -;; **async**, because a synchronous call on a timer blocks Emacs's UI every -;; tick; and the paint is `replace-buffer-contents' rather than erase-and- -;; insert, because it diffs, so point and scroll survive a repaint instead of -;; being yanked to the top five times a second. +;; The daemon reads the table and sends it on the editor's connection, as it +;; sends the program's output, so Emacs never waits on a timer for it. The +;; paint is `replace-buffer-contents' rather than erase-and-insert, because it +;; diffs, so point and scroll survive a repaint instead of being yanked to the +;; top five times a second. ;; ;; What a program writes: ;; @@ -92,19 +92,17 @@ "Seconds between repaints. This is the *repaint* rate, not the watch rate. The program writes its values -every frame whatever this is; all this decides is how often the picture is -refreshed, which is why a slow value here costs freshness and nothing else." +every frame whatever this is; all this decides is how often the daemon sends +the table, which is why a slow value here costs freshness and nothing else. +Taken when the table is armed, so a change applies from the next `flan-watch'." :type 'number) -(defvar flan-watch--timer nil) -(defvar flan-watch--pending nil - "Non-nil while a watch request is out and its reply has not been read.") (defvar flan-watch--rows nil "The last table painted, as a list of (NAME . VALUE).") (defvar flan-watch--consumers nil "Which pictures of the table are currently wanted: `buffer', `ghost', or both. -There is one table, one arming message and one timer, and more than one way to +There is one table, one arming message and one push, and more than one way to look at what they produce. Holding the subscription here rather than in the watch buffer is what lets ghost text outlive that buffer being closed — the original design made the buffer *be* the subscription, which was right when it @@ -183,12 +181,11 @@ was the only consumer and wrong the moment it was not.") ;; the string literal and not the head is what makes that safe: a name in the ;; table came from one of these call sites by construction. ;; -;; WHEN IT UPDATES. On the same timer, from the same reply. The two pictures -;; therefore cannot disagree — they are one table read, painted twice — and -;; there is no second `:op "watch"' in flight, which is the invariant -;; `flan-settle-hook' exists to keep. As with the buffer, the timer decides -;; how often the picture is repainted and not how fresh it is: the program -;; writes every frame regardless. +;; WHEN IT UPDATES. On the same push, from the same frame. The two pictures +;; therefore cannot disagree — they are one table read, painted twice. As +;; with the buffer, the push interval decides how often the picture is +;; repainted and not how fresh it is: the program writes every frame +;; regardless. ;; ;; Overlays are deleted and re-placed from scratch on every repaint rather than ;; being tracked across edits. That is the whole answer to the invalidation @@ -335,10 +332,10 @@ Guarded on the row's length so a short name cannot be claimed by accident." (overlay-put ov 'flan-watch-ghost t) (push ov flan-watch--ghost-overlays)))))))))) -;;; The tick +;;; The push (defun flan-watch--absorb (reply) - "Paint REPLY, a watch answer from the daemon." + "Paint REPLY, a watch table from the daemon." (pcase (plist-get reply :status) ("ok" (setq flan-watch--rows @@ -357,94 +354,72 @@ Guarded on the row's length so a short name cannot be claimed by accident." (flan-watch--paint (format "error:\n%s\n" (or (plist-get reply :message) "refused")))))) -(defun flan-watch--settle () - "Collect an outstanding watch reply, blocking if it has not arrived. +;; The daemon sends the table on the connection every `flan-watch-interval' +;; while it is armed and has changed, the same way it sends the program's +;; output. Nothing here sends a request on a timer, so nothing here can leave +;; a reply in flight for another request to read. +;; +;; Each push closes the numeric slots' accumulation window, so their count, +;; range and mean are "since the last push" rather than since the program +;; started — except while the program is stopped, when the window is left open +;; and the numbers from the moment it stopped stay on the screen. The daemon +;; decides that, since it knows whether the program is stopped when it reads +;; the table. -Hung on `flan-settle-hook', so an ordinary request never reads the watch -timer's reply as its own. Blocking here is fine and blocking in the tick is -not: this runs inside something a person asked for, which already waits, and -what it waits for is a table read with nothing compiled behind it." - (when flan-watch--pending - (setq flan-watch--pending nil) - (when-let* ((proc flan--connection)) - (when (process-live-p proc) - (ignore-errors (flan-watch--absorb (flan--read-reply proc))))))) +(defun flan-watch--on-push (kind frame) + "Paint FRAME when KIND says it is the watch table." + (when (and (equal kind "watch") flan-watch--consumers) + (flan-watch--absorb frame))) -(defun flan-watch--tick () - "Collect the last reply if it has come, then ask again. Never blocks. +(defun flan-watch--on-connect () + "Arm the table again on a new connection, if anything is watching. +A restarted daemon has a new program, and the new program's table is off." + (when flan-watch--consumers + (let ((r (ignore-errors (flan-watch--arm t)))) + (unless (equal (plist-get r :status) "ok") + (flan-watch--paint + (format "error:\n%s\n" + (or (plist-get r :message) "the table could not be armed"))))))) -Deliberately not `flan--request', which waits for its answer: a -synchronous call on a 0.2s timer stalls Emacs's UI every tick, and a timer is -the one caller that must not. So this takes whatever has already arrived and -sends the next question, leaving at most one request in flight — the invariant -`flan-settle-hook' exists to keep." - (cond - ;; Killing the buffer cancels the buffer's half of the subscription, and - ;; only that. When it was the only consumer this stops the timer and - ;; disarms the table, so a program nobody is watching is back to paying a - ;; load and a branch per watch call; when ghost text is also on, the table - ;; stays armed and the ticks carry on feeding it. - ((and (memq 'buffer flan-watch--consumers) - (not (get-buffer flan-watch-buffer))) - (flan-watch--drop 'buffer)) - ((not (process-live-p flan--connection)) - (flan-watch--paint "error:\nnot connected to a running program\n") - (flan-watch-stop)) - ;; Something else owns the connection this instant — an evaluation is - ;; mid-flight. Skipping is right: its `flan-settle-hook' has already - ;; taken any reply of ours, and the next tick is 0.2s away. - (flan--busy nil) - (t - (when flan-watch--pending - ;; Taken off the connection either way. `flan--extract-reply' - ;; deletes a frame before it reads it, so a payload that will not read - ;; has still been consumed — and a pending flag left standing after it - ;; would wait for ever for a reply that is no longer in the buffer, - ;; which stops the timer sending anything again. One bad reply costs - ;; one tick, not the session. - (when-let* ((reply (condition-case nil - (flan--take-reply flan--connection) - (error (setq flan-watch--pending nil) nil)))) - (setq flan-watch--pending nil) - (flan-watch--absorb reply))) - (unless flan-watch--pending - (condition-case nil - ;; `:reset t' opens a new accumulation window for the numeric - ;; slots, so their count, range and mean are "since the last tick" - ;; rather than since the program started. That is the whole of the - ;; accumulator decision as the editor sees it: a min and a max over - ;; a session go dead within seconds of play, and this tool exists to - ;; show a number while you drag the mouse. The reset happens after - ;; the read, on the daemon's side, so this tick's numbers are the - ;; last tick's window and nothing is lost between the two. - ;; - ;; Except while the program is stopped, when the read still happens - ;; and the reset does not. A stopped program takes no samples, so - ;; there is no window for a reset to close and none for it to open: - ;; the runtime clears a slot lazily, on its next sample, which is - ;; what keeps a paused program showing the numbers from the moment - ;; you paused it — the whole reason to pause. Resetting anyway - ;; would ask for a new window five times a second that nothing can - ;; fill. The guard lives here rather than in the runtime because - ;; "since you last looked" is the editor's policy, not the table's. - ;; `flan--stopped' is the one place that state is tracked, and - ;; `flan.el''s background poll keeps it current whether or not - ;; anyone is evaluating. - (progn (flan--send flan--connection - (if flan--stopped - '(:op "watch") - '(:op "watch" :reset t))) - (setq flan-watch--pending t)) - (error (flan-watch-stop))))))) +(defun flan-watch--on-disconnect () + "Say that the table is no longer live." + (when flan-watch--consumers + (flan-watch--ghost-clear) + (flan-watch--paint "error:\nnot connected to a running program\n"))) + +(defun flan-watch--arm (on) + "Ask the daemon to arm the table and push it, or to disarm it when ON is nil." + (flan--request (if on + `(:op "watch-enable" :on t :interval ,flan-watch-interval) + '(:op "watch-enable" :on nil)))) ;;; Commands +(defvar flan-watch-mode-map + (let ((map (make-sparse-keymap))) + ;; As `flan-doc-mode-map'. + (define-key map "q" #'quit-window) + map) + "Keys in `flan-watch-mode'.") + +(flan-evil-own-keys 'flan-watch-mode-map) + (define-derived-mode flan-watch-mode special-mode "flan-watch" "Major mode for the pinned watch buffer." - (setq-local truncate-lines t)) + (setq-local truncate-lines t) + ;; Killing the buffer cancels the buffer's half of the subscription, and only + ;; that. When it was the only consumer the table is disarmed, so a program + ;; nobody is watching is back to paying a load and a branch per watch call; + ;; when ghost text is also on, the table stays armed. + (add-hook 'kill-buffer-hook #'flan-watch--buffer-killed nil t)) + +(defun flan-watch--buffer-killed () + "Drop the buffer consumer, the watch buffer being killed." + (when (memq 'buffer flan-watch--consumers) + (flan-watch--drop 'buffer))) (defun flan-watch--subscribe (consumer) - "Arm the table for CONSUMER and make sure the shared timer is running. + "Arm the table for CONSUMER. Arming is a message, not something the daemon infers. The program is the writer, so it has to be told somebody is looking — and while nobody is, nothing @@ -453,15 +428,14 @@ debugging a load and a not-taken branch. It is sent once for the first consumer: two of them looking at one table is still one table." (flan--live-connection) (unless flan-watch--consumers - (let ((r (flan--request '(:op "watch-enable" :on t)))) + (let ((r (flan-watch--arm t))) (unless (equal (plist-get r :status) "ok") (user-error "flan: %s" (or (plist-get r :message) "watch refused"))))) (unless (memq consumer flan-watch--consumers) (push consumer flan-watch--consumers)) - (add-hook 'flan-settle-hook #'flan-watch--settle) - (when flan-watch--timer (cancel-timer flan-watch--timer)) - (setq flan-watch--timer - (run-with-timer 0 flan-watch-interval #'flan-watch--tick))) + (add-hook 'flan-push-functions #'flan-watch--on-push) + (add-hook 'flan-connected-hook #'flan-watch--on-connect) + (add-hook 'flan-disconnected-hook #'flan-watch--on-disconnect)) (defun flan-watch--drop (consumer) "Stop painting CONSUMER, and tear everything down if it was the last one." @@ -476,7 +450,7 @@ consumer: two of them looking at one table is still one table." (flan-watch--subscribe 'buffer) (with-current-buffer (get-buffer-create flan-watch-buffer) (unless (eq major-mode 'flan-watch-mode) (flan-watch-mode))) - ;; Painted before the first reply, rather than left blank until one arrives. + ;; Painted before the first push, rather than left blank until one arrives. ;; An empty buffer is the same picture as a broken one, and the likeliest ;; reason for it here is the honest one — the program is not calling into the ;; table — which is worth saying in words rather than by showing nothing. @@ -510,21 +484,15 @@ Tears down both consumers. `flan-watch--drop' is the way to stop one of them." ;; `flan-watch--drop' and back into here. (setq flan-watch-ghost-mode nil) (flan-watch--ghost-clear) - (when flan-watch--timer - (cancel-timer flan-watch--timer) - (setq flan-watch--timer nil)) - ;; Settle before disarming, or the disarm request reads the tick's reply. - (flan-watch--settle) - (remove-hook 'flan-settle-hook #'flan-watch--settle) - ;; Only on a connection that is already live, and this is the important half. - ;; `flan--request' *reconnects* — which is right for something a person - ;; did and wrong here, because this is also called from the tick, and the - ;; reason the tick calls it is that the connection has gone. Reconnecting - ;; from a timer would quietly erase the `lost' state that exists to be seen, - ;; which `flan.el' already forbids for its own poll timer. And there is - ;; nothing to disarm anyway: the table went with the program. + (remove-hook 'flan-push-functions #'flan-watch--on-push) + (remove-hook 'flan-connected-hook #'flan-watch--on-connect) + (remove-hook 'flan-disconnected-hook #'flan-watch--on-disconnect) + ;; Only on a connection that is already live. `flan--request' reconnects, + ;; which is right for something a person did and wrong here: there is + ;; nothing to disarm when the connection has gone, because the table went + ;; with the program. (when (process-live-p flan--connection) - (ignore-errors (flan--request '(:op "watch-enable" :on nil))))) + (ignore-errors (flan-watch--arm nil)))) ;;; What ghost text still cannot show diff --git a/emacs/flan.el b/emacs/flan.el index f0e77dfd..be3b879f 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -244,44 +244,96 @@ to." 'utf-8 t))) (process-send-string proc (format "%d\n%s" (length payload) payload)))) -(defun flan--take-reply (proc) - "Read one complete framed message out of PROC's buffer, or return nil. +;; Two kinds of frame arrive on the connection. A reply answers the request +;; that is waiting for it. A push is sent without being asked for — the +;; program's output as it is printed, and the watch table while one is armed — +;; and is marked `:push' with its kind. The daemon sends pushes only to a +;; connection that asked for them (`flan--open' does), and never in the middle +;; of a reply. +;; +;; The process filter takes every complete frame off the head of the buffer as +;; it arrives: a push is handled there and then, which is what puts a +;; `println' on the screen as it happens, and a reply is queued on the process +;; for `flan--read-reply' to collect. The reader runs the same collection +;; itself before it looks, so frames that reached the buffer by some other way +;; than the filter are read the same. -Never waits. This is the half of `flan--read-reply' that does not block, -split out for the watch timer: a timer that called `accept-process-output' -would stall the UI every tick, which is exactly the mistake the Clojure -original left a comment about. See `flan-watch--tick'." +(defvar flan-push-functions nil + "Functions called with each push from the daemon other than output. +Each is called with two arguments, the kind as a string (\"watch\") and the +frame as a plist. Output is handled by `flan--append-output' directly.") + +(defun flan--dispatch-push (frame) + "Handle FRAME, a push from the daemon. +Errors are reported and go no further: this runs inside a process filter, +where an error would stop the frames behind it from being read." + (with-demoted-errors "flan: a push from the daemon failed: %S" + (let ((kind (plist-get frame :push))) + (if (equal kind "output") + (flan--append-output (plist-get frame :output)) + (run-hook-with-args 'flan-push-functions kind frame))))) + +(defun flan--collect (proc) + "Take every complete frame off the head of PROC's buffer. +A push is dispatched; a reply is queued for `flan--take-reply'. A reply that +will not read is queued as its error, so the request that asked for it is the +one that signals." (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) - (goto-char (point-min)) - (when (re-search-forward "\\`\\([0-9]+\\)\n" nil t) - (let* ((n (string-to-number (match-string 1))) - (body-start (point))) - ;; Present in full, or not yet — a partial body is not an error here, - ;; it is the ordinary state between the send and the reply. - (when (>= (- (position-bytes (point-max)) (position-bytes body-start)) n) - (flan--extract-reply body-start n))))))) + (let (frame) + (while (setq frame (progn (goto-char (point-min)) + (flan--next-frame))) + (let ((text (car frame))) + (if (string-prefix-p "(:push " text) + (condition-case nil + (flan--dispatch-push (car (read-from-string text))) + ;; An unreadable push is a daemon bug, and it answers + ;; nobody's request, so nothing is queued for it. + (error (message "flan: an unreadable push from the daemon was dropped"))) + (process-put proc 'flan-replies + (append (process-get proc 'flan-replies) + (list (condition-case err + (cons 'ok (car (read-from-string text))) + (error (cons 'bad err))))))))))))) -(defun flan--extract-reply (body-start n) - "Read the N bytes at BODY-START as a reply and delete the frame. -Point is in the process buffer, and the frame is known to be complete. +(defun flan--next-frame () + "Remove the complete frame at point-min and return (TEXT), or return nil. +Point is in a process buffer. The frame is deleted before anything reads it, +so a payload that will not read is consumed once rather than read again by +every request after it." + (when (re-search-forward "\\`\\([0-9]+\\)\n" nil t) + (let* ((n (string-to-number (match-string 1))) + (body-start (point))) + ;; Present in full, or not yet — a partial body is the ordinary state + ;; between the first packet of a frame and its last. + (when (>= (- (position-bytes (point-max)) (position-bytes body-start)) n) + (let* ((end (byte-to-position (+ (position-bytes body-start) n))) + (text (decode-coding-string + (encode-coding-string (buffer-substring-no-properties + body-start end) + 'utf-8 t) + 'utf-8))) + (delete-region (point-min) end) + (list text)))))) -The frame is deleted *before* it is read, which is the whole of the ordering -and the only reason this is worth a comment. A payload that will not read is -a bug at the other end, and the client's job is to report it once: reading -first would leave those bytes at the head of the buffer, so the next request -would read the same unreadable frame again, and every request after that — -one bad reply and the connection is wedged until Emacs is restarted. -Consuming it first costs the reply, which was lost anyway, and leaves the -stream in step for the request that follows." - (let* ((end (byte-to-position (+ (position-bytes body-start) n))) - (text (decode-coding-string - (encode-coding-string (buffer-substring-no-properties - body-start end) - 'utf-8 t) - 'utf-8))) - (delete-region (point-min) end) - (car (read-from-string text)))) +(defun flan--filter (proc string) + "Append STRING to PROC's buffer and take off whatever frames are complete." + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (goto-char (point-max)) + (insert string)) + (flan--collect proc))) + +(defun flan--take-reply (proc) + "The next reply PROC has sent, or nil if none has arrived. Never waits. +A reply that would not read signals here, having already been consumed." + (flan--collect proc) + (let ((q (process-get proc 'flan-replies))) + (when q + (process-put proc 'flan-replies (cdr q)) + (pcase (car q) + (`(ok . ,reply) reply) + (`(bad . ,err) (signal (car err) (cdr err))))))) (defun flan--no-reply (proc) "Signal that PROC has not answered, saying which of the two silences it is. @@ -306,41 +358,33 @@ Reconnecting happens before a send, never after one." (abbreviate-file-name (or flan--socket "?"))))) (defun flan--read-reply (proc) - "Block until PROC sends one complete framed message, and read it." - (with-current-buffer (process-buffer proc) - (let ((deadline (+ (float-time) flan-reply-timeout))) - ;; The header first: digits up to a newline. - (while (and (not (save-excursion (goto-char (point-min)) - (re-search-forward "\\`\\([0-9]+\\)\n" nil t))) - (< (float-time) deadline)) - (accept-process-output proc 0.05)) - (goto-char (point-min)) - ;; Nothing is erased here, and that is the difference between the two - ;; deadlines. A header that has not arrived in full is a valid prefix - ;; of a reply still on its way — throwing it away would turn a daemon - ;; that is merely slow into a stream out of step by however much of the - ;; count had landed. - (unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t) - (flan--no-reply proc)) - (let* ((n (string-to-number (match-string 1))) - (body-start (point))) - (while (and (< (- (position-bytes (point-max)) (position-bytes body-start)) n) - (< (float-time) deadline)) - (accept-process-output proc 0.05)) - (if (>= (- (position-bytes (point-max)) (position-bytes body-start)) n) - (flan--extract-reply body-start n) - ;; The body never came, so the count at the head of the buffer is a - ;; promise about bytes that will never be made good: reading on from - ;; here would take the *next* reply's header as this one's payload - ;; and every request after it would be answered by the one before. - ;; The frame is dead — drop it, and the connection is in step again - ;; for whatever a person does next. Testing the condition again - ;; rather than trusting the loop is the whole fix: falling through - ;; to `flan--extract-reply' with a short buffer signals a - ;; wrong-type error from `byte-to-position', which says nothing - ;; about a timeout to whoever reads it. - (erase-buffer) - (flan--no-reply proc)))))) + "Block until PROC sends a reply, and return it. +Pushes that arrive first are handled as they come." + (let ((deadline (+ (float-time) flan-reply-timeout)) + (got nil) (reply nil)) + (while (and (not got) (< (float-time) deadline)) + (if (process-get proc 'flan-replies) + (setq reply (flan--take-reply proc) got t) + (flan--collect proc) + (unless (process-get proc 'flan-replies) + (accept-process-output proc 0.05)))) + (unless got + (setq got (and (process-get proc 'flan-replies) t)) + (when got (setq reply (flan--take-reply proc)))) + (unless got + ;; A header whose body never came is a promise about bytes that will + ;; never be made good: reading on from here would take the *next* + ;; reply's header as this one's payload, and every request after it + ;; would be answered by the one before. The frame is dead, so it is + ;; dropped. A header that has not arrived in full is left, being a + ;; valid prefix of a frame still on its way. + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (when (re-search-forward "\\`\\([0-9]+\\)\n" nil t) + (erase-buffer)))) + (flan--no-reply proc)) + reply)) ;; Written by `flan--append-output' when a REPL is open; defined in ;; flan-repl.el, which requires this file, so the reference here has to be a @@ -496,24 +540,6 @@ with it, and a rejected evaluation is a likely moment to *become* stopped." (run-at-time 0 nil #'flan--auto-break)))) reply) -(defvar flan-settle-hook nil - "Run before anything is sent, against the connection as it stands. - -The protocol is one reply per request on one connection, and that is the whole -reason this exists. Anything that sends without waiting — the watch timer is -the only such thing — leaves a reply in flight that the *next* request would -otherwise read as its own. So a sender-in-flight hangs a function here that -collects its own reply first, and the invariant holds: exactly one request -outstanding, and every reply consumed by whoever asked for it. - -Before the connection is checked, not after, and that ordering is the point. -An outstanding reply belongs to the connection it was asked on; if the daemon -has been restarted under Emacs, that connection is gone and no reply is coming -on the new one. Running this first is what lets a hook see that for itself -and drop its pending flag, rather than sitting out a full -`flan-reply-timeout' waiting on a socket the question was never asked -down.") - (defun flan--request (form) "Send FORM to the connected program and return its reply." ;; `flan--busy' first of all, and around the reconnect as well as around @@ -522,7 +548,6 @@ down.") ;; middle of that would be a second conversation on the connection this one ;; just opened. (let ((flan--busy t)) - (run-hooks 'flan-settle-hook) (let ((proc (flan--live-connection))) (flan--absorb (progn (flan--send proc form) (flan--read-reply proc)))))) @@ -563,18 +588,10 @@ Set to nil to leave the program's state to whatever replies happen to say." (let ((proc flan--connection) (flan--busy t)) (ignore-errors - ;; The same settle every other sender does, and for the same reason. - ;; `flan--busy' is not enough on its own: the watch timer leaves a - ;; request in flight and *clears* nothing, deliberately — it binds no - ;; busy flag, because it never waits — so a poll that checked only the - ;; flag would send `describe' with the watch's reply still coming and - ;; read that instead. The two would then stay swapped for the rest of - ;; the session, each consumer answering the other's question, which is - ;; exactly the interleaving `flan-settle-hook' exists to prevent. - (run-hooks 'flan-settle-hook) - ;; `describe' rather than `break': it is the cheap op, it is what - ;; drains the program's output, and the state is on every reply anyway. - ;; Asking `break' would fetch restart names nobody is choosing from. + ;; `describe' rather than `break': it is the cheap op, and the state + ;; is on every reply anyway. Asking `break' would fetch restart names + ;; nobody is choosing from. The program's output does not wait for + ;; this; the daemon pushes it as it is printed. (flan--send proc '(:op "describe")) (flan--absorb (flan--read-reply proc)))))) @@ -611,14 +628,37 @@ Set to nil to leave the program's state to whatever replies happen to say." (setq flan--connection (make-network-process :name "flan" :buffer buf :family 'local :service socket - :coding 'binary :noquery t)) + :coding 'binary :noquery t + :filter #'flan--filter :sentinel #'flan--sentinel)) (setq flan--socket socket)) (setq flan--stopped nil) (setq flan--parked nil) + ;; Output and the watch table come as they happen from here on. A daemon + ;; that does not know the op refuses it and nothing else changes. + (let ((flan--busy t)) + (ignore-errors + (flan--send flan--connection '(:op "push" :on t)) + (flan--absorb (flan--read-reply flan--connection)))) (flan--start-polling) (force-mode-line-update t) + (run-hooks 'flan-connected-hook) flan--connection) +(defvar flan-connected-hook nil + "Run after a connection to a daemon is opened, including a reconnect.") + +(defvar flan-disconnected-hook nil + "Run when the current connection to the daemon closes.") + +(defun flan--sentinel (proc _event) + "Notice PROC closing, when it is the current connection." + ;; nil is `flan-disconnect', which clears the connection before the + ;; sentinel runs; a different live process is a reconnect that replaced it. + (when (and (or (eq proc flan--connection) (null flan--connection)) + (not (process-live-p proc))) + (force-mode-line-update t) + (with-demoted-errors "flan: %S" (run-hooks 'flan-disconnected-hook)))) + ;; A daemon restarted while Emacs was not looking is the ordinary case, not an ;; exceptional one: `flan dev' ends when its program does, and a program under ;; development exits all the time. So a dead connection is reopened on the @@ -1497,9 +1537,15 @@ no longer wrong." ;; major-mode half, possible because the buffer is read-only. (define-key map (kbd "n") #'compilation-next-error) (define-key map (kbd "p") #'compilation-previous-error) + ;; The minor mode's RET and `special-mode-map''s q, bound here as well so + ;; that they are this mode's own keys and reach Evil's states. + (define-key map (kbd "RET") #'compile-goto-error) + (define-key map "q" #'quit-window) map) "Keymap for `flan-diagnostics-mode'.") +(flan-evil-own-keys 'flan-diagnostics-mode-map) + (define-derived-mode flan-diagnostics-mode special-mode "Flan-Diagnostics" "Every message the compiler handed the editor, one navigable list. `n' and `p' move between entries, RET goes to the line one names. @@ -2220,6 +2266,16 @@ in this program; C-c C-v describes it" (car d))) (defvar flan-doc-buffer "*flan-doc*" "Buffer `flan-doc' writes into.") +(defvar flan-doc-mode-map + (let ((map (make-sparse-keymap))) + ;; `special-mode-map''s q, as this mode's own key so that it reaches + ;; Evil's states; see `flan-evil-own-keys'. + (define-key map "q" #'quit-window) + map) + "Keys in `flan-doc-mode'.") + +(flan-evil-own-keys 'flan-doc-mode-map) + (define-derived-mode flan-doc-mode special-mode "Flan-Doc" "Mode for the buffer `flan-doc' writes.") @@ -2849,6 +2905,15 @@ does, until the same form is evaluated again without a prefix." (defvar flan-disassembly-buffer "*flan-disassembly*" "Buffer `flan-disassemble' writes into.") +(defvar flan-disassembly-mode-map + (let ((map (make-sparse-keymap))) + ;; As `flan-doc-mode-map'. + (define-key map "q" #'quit-window) + map) + "Keys in `flan-disassembly-mode'.") + +(flan-evil-own-keys 'flan-disassembly-mode-map) + (define-derived-mode flan-disassembly-mode special-mode "Flan-Disasm" "Mode for the buffer `flan-disassemble' writes." (setq-local truncate-lines t)) diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 84a93172..662db688 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1912,7 +1912,39 @@ stopped program, which is the case where it should fire." ("<" . evil-shift-left) ("-" . evil-previous-line-first-non-blank))) (test-flan--check (format "under Evil, %s is still Evil's" (car k)) - (eq (key-binding (kbd (car k))) (cdr k))))) + (eq (key-binding (kbd (car k))) (cdr k)))) + ;; The other buffers of Flan's own: every key a mode's map binds + ;; itself does what it does without Evil, and the keys it does not + ;; bind stay Evil's. + (require 'flan-lower) + (require 'flan-watch) + (dolist (m '((flan-inspect-mode . flan-inspect-mode-map) + (flan-watch-mode . flan-watch-mode-map) + (flan-doc-mode . flan-doc-mode-map) + (flan-disassembly-mode . flan-disassembly-mode-map) + (flan-diagnostics-mode . flan-diagnostics-mode-map) + (flan-lower-mode . flan-lower-mode-map))) + (let ((b (get-buffer-create (format " *evil-%s*" (car m)))) + (own nil)) + (map-keymap-internal + (lambda (key def) (when (commandp def) (push (cons key def) own))) + (symbol-value (cdr m))) + (switch-to-buffer b) + (funcall (car m)) + (evil-initialize-state) + (test-flan--check (format "%s binds keys of its own" (car m)) own) + (dolist (k own) + (test-flan--check + (format "under Evil, %s in %s is the mode's" + (key-description (vector (car k))) (car m)) + (eq (key-binding (vector (car k))) (cdr k)))) + (dolist (k '(("h" . evil-backward-char) ("SPC" . evil-forward-char) + ("<" . evil-shift-left) + ("-" . evil-previous-line-first-non-blank))) + (test-flan--check (format "under Evil, %s in %s is still Evil's" + (car k) (car m)) + (eq (key-binding (kbd (car k))) (cdr k)))) + (kill-buffer b)))) (evil-mode -1)))) (message "\n%d checks, %d failures" test-flan--ran test-flan--failures) diff --git a/emacs/test-flan-watch.el b/emacs/test-flan-watch.el index 31ff470b..8c43156f 100644 --- a/emacs/test-flan-watch.el +++ b/emacs/test-flan-watch.el @@ -210,54 +210,67 @@ what bounds its cost; a `with-temp-buffer' would be scanned by nothing." (test-flan--check "and the last consumer out disarms the table" (and (null flan-watch--consumers) torn)))) -;; --- The reset is guarded on the stop ------------------------------------ +;; --- Pushes and replies on one connection --------------------------------- ;; -;; `flan-watch--tick' asks for "since you last looked" by sending `:reset t' -;; beside the read. A stopped program takes no samples, so there is no window -;; for a reset to close and none for it to open — and the runtime's lazy clear -;; is what keeps a paused program showing the numbers from the moment you -;; paused it. So the tick must drop `:reset' while stopped and keep reading. -;; -;; Asserted at the level the rest of this file works at: no daemon, no socket. -;; The tick is a function from `flan--stopped' to the form it puts on the -;; wire, and that is the whole claim, so `flan--send' and `process-live-p' -;; are stubs. What this cannot reach is the daemon actually honouring the -;; absent field; `test/test_dev.ml' drives a real program for that. +;; The daemon writes two kinds of frame: replies, and pushes it sends without +;; being asked — output as it is printed, the watch table while it is armed. +;; The filter handles a push as it arrives and queues a reply for whoever is +;; waiting. Frames are written into a pipe process's buffer by hand, split +;; mid-frame the way a socket may deliver them, so what is claimed is the +;; reader and not the daemon. -(defun test-flan-watch--tick-form (stopped) - "The form `flan-watch--tick' sends with the program STOPPED or not." - (let ((sent nil) - (flan--stopped stopped) - (flan--connection 'a-process) - (flan--busy nil) - (flan-watch--pending nil) - ;; Not `buffer': that consumer checks for a live watch buffer first and - ;; would drop the subscription instead of ticking. - (flan-watch--consumers '(ghost))) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) - ((symbol-function 'flan--take-reply) (lambda (_) nil)) - ((symbol-function 'flan--send) - (lambda (_proc form) (setq sent form)))) - (flan-watch--tick) - (list sent flan-watch--pending)))) +(defun test-flan-watch--frame (form) + "FORM framed as the daemon frames it." + (let ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t))) + (format "%d\n%s" (length payload) payload))) -(let ((running (test-flan-watch--tick-form nil)) - (stopped (test-flan-watch--tick-form "BoundsError"))) - (test-flan--check - "a tick while the program runs asks for the window it is closing" - (equal (nth 0 running) '(:op "watch" :reset t))) - (test-flan--check - "a tick while the program is stopped sends no reset" - (null (plist-get (nth 0 stopped) :reset))) - ;; Skipping the tick outright would be worse than resetting: the watch would - ;; freeze at whatever it held when the program stopped, and a break loop is - ;; exactly when the numbers are being read. - (test-flan--check - "but it still reads the table" - (equal (plist-get (nth 0 stopped) :op) "watch")) - (test-flan--check - "and still has a reply in flight, so the cycle survives the pause" - (and (nth 1 running) (nth 1 stopped)))) +(let* ((buf (generate-new-buffer " *flan-push-test*")) + (proc (make-pipe-process :name "flan-push-test" :buffer buf + :noquery t)) + (painted nil) + (appended nil) + (flan-watch--consumers '(ghost))) + (with-current-buffer buf (set-buffer-multibyte nil)) + (unwind-protect + (cl-letf (((symbol-function 'flan-watch--absorb) + (lambda (r) (push r painted))) + ((symbol-function 'flan--append-output) + (lambda (text) (push text appended)))) + (let ((flan-push-functions '(flan-watch--on-push)) + (stream + (concat + (test-flan-watch--frame '(:push "output" :status "ok" + :output "héllo\n")) + (test-flan-watch--frame '(:status "ok" :value "42")) + (test-flan-watch--frame '(:push "watch" :status "ok" + :watch (("ticks" "7")) + :overflow nil))))) + ;; In three pieces, the first ending inside the first frame's body. + (flan--filter proc (substring stream 0 12)) + (test-flan--check "a push is not handled before all of it has arrived" + (null appended)) + (flan--filter proc (substring stream 12 40)) + (flan--filter proc (substring stream 40)) + (test-flan--check "an output push reaches the output as it arrives" + (equal appended + (list (decode-coding-string + (encode-coding-string "héllo\n" 'utf-8) + 'utf-8)))) + (test-flan--check "a watch push behind a reply is painted without waiting for the reply to be read" + (equal (plist-get (car painted) :watch) + '(("ticks" "7")))) + (test-flan--check "and the reply is kept for the request that asked" + (equal (flan--take-reply proc) + '(:status "ok" :value "42"))) + (test-flan--check "and taken once" + (null (flan--take-reply proc))) + (let ((flan-watch--consumers nil)) + (flan--filter proc (test-flan-watch--frame + '(:push "watch" :status "ok" :watch nil))) + (test-flan--check "a watch push with nothing watching paints nothing" + (= 1 (length painted)))))) + (delete-process proc) + (kill-buffer buf))) (provide 'test-flan-watch) ;;; test-flan-watch.el ends here diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 3a6ae6ce..3f4f1ee7 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -536,13 +536,47 @@ already rely on it — so nothing here is a stand-in for the real thing." ;; The program's own output arrives on replies and lands in the daemon's ;; buffer — no REPL is open yet, and the log is the fallback that makes a ;; println never depend on one. + ;; + ;; And it arrives without anything being asked. The poll is stopped and no + ;; request is sent while this waits, so the only way HELLO can reach the + ;; buffer is the daemon pushing it. (flan--eval "(defn step [] i64 (do (println \"HELLO\") ticks))" "form") - (let ((seen nil) (deadline (+ (float-time) 10))) - (while (and (not seen) (< (float-time) deadline)) - (ignore-errors (flan--request '(:op "describe"))) - (setq seen (with-current-buffer (get-buffer-create flan-daemon-buffer) - (string-match-p "HELLO" (buffer-string))))) - (test-flan--check "the program's output reaches the daemon's buffer" seen)) + (flan--stop-polling) + (with-current-buffer (get-buffer-create flan-daemon-buffer) + (let ((inhibit-read-only t)) (erase-buffer))) + (let* ((pushes 0) + (count (lambda (frame) + (when (equal (plist-get frame :push) "output") + (setq pushes (1+ pushes))))) + (started (float-time)) + (seen nil)) + (advice-add 'flan--dispatch-push :before count) + (unwind-protect + (progn + (while (and (not seen) (< (float-time) (+ started 10))) + (accept-process-output flan--connection 0.01) + (setq seen (with-current-buffer flan-daemon-buffer + (string-match-p "HELLO" (buffer-string))))) + (let ((took (- (float-time) started))) + (test-flan--check "the program's output reaches the daemon's buffer" seen) + (test-flan--check + (format "without a request, in well under a second (%.3fs)" took) + (and seen (< took 0.3)))) + ;; The program prints every 5ms. Coalesced, a second of that is at + ;; most one push per 50ms, not two hundred. + (setq pushes 0) + (let ((until (+ (float-time) 1.0))) + (while (< (float-time) until) + (accept-process-output flan--connection 0.02))) + (test-flan--check + (format "a burst of output is coalesced (%d pushes in 1s)" pushes) + (<= 5 pushes 25))) + (advice-remove 'flan--dispatch-push count) + (flan--start-polling))) + ;; A request made while the program prints still gets its own reply. + (test-flan--check "a request while output is being pushed gets its own reply" + (member "step" (plist-get (flan--request '(:op "describe")) + :fns))) ;; ── Which evaluator C-x C-e reaches ────────────────────────────────── ;; @@ -1314,68 +1348,58 @@ already rely on it — so nothing here is a stand-in for the real thing." ;; ;; test_dev.ml proves the table itself: a program pushes and the daemon reads ;; it back without compiling anything. What is left to prove here is the - ;; part that is only true in Emacs, and it is not the painting — it is that - ;; an *asynchronous* sender and the ordinary synchronous request can share one - ;; connection. - ;; - ;; The protocol is one reply per request on one socket. The watch timer - ;; sends and does not wait, deliberately, because waiting on a 0.2s timer - ;; stalls the UI. That leaves a reply in flight that the next C-c C-c would - ;; read as its own — an evaluation reporting the watch table's answer, which - ;; is the exact bug `flan-settle-hook' exists to make impossible. This - ;; program writes nothing into the table, which does not matter: the - ;; interleaving is the claim. - (flan-watch) - (test-flan--check "the watch buffer opens" (get-buffer flan-watch-buffer)) - (test-flan--check "and the timer is running" flan-watch--timer) - (test-flan--check "a program that watches nothing says so, rather than looking broken" - (with-current-buffer flan-watch-buffer - (string-match-p "nothing is being watched" (buffer-string)))) - ;; The tick by hand, so this does not depend on a timer firing inside a batch - ;; run. Two of them: the first sends, the second collects and sends again. - (flan-watch--tick) - (test-flan--check "a tick leaves a request in flight rather than waiting for it" - flan-watch--pending) - ;; The background poll is a sender too, and it was the one sender that did - ;; not settle: it guarded on `flan--busy' alone, which the watch timer - ;; deliberately does not bind — it never waits, so it has nothing to hold — - ;; and sent `describe' straight into a connection that already owed a reply. - ;; It then read the watch's answer as its own, and the two stayed swapped - ;; for the rest of the session. The second check is where that would show: - ;; a `describe' answered by the watch table has no `:fns' in it at all. - (flan--poll) - (test-flan--check "a poll settles the watch's reply rather than reading it as its own" - (null flan-watch--pending)) - (test-flan--check "and the request after it is still answered by its own reply" + ;; part that is only true in Emacs: the daemon sends the table on the same + ;; connection that carries replies, unasked, and neither gets in the way of + ;; the other. + (let ((pushes 0)) + (let ((count (lambda (_r) (setq pushes (1+ pushes))))) + (advice-add 'flan-watch--absorb :before count) + (unwind-protect + (progn + (flan-watch) + (test-flan--check "the watch buffer opens" (get-buffer flan-watch-buffer)) + (test-flan--check "a program that watches nothing says so, rather than looking broken" + (with-current-buffer flan-watch-buffer + (string-match-p "nothing is being watched" (buffer-string)))) + ;; A body that writes the table, so there is something to send. + (flan--eval "(defn step [] i64 (set ticks (+ ticks 1)) (watch \"ticks\" ticks) ticks)" + "form") + (let ((until (+ (float-time) 5))) + (while (and (< (float-time) until) + (not (with-current-buffer flan-watch-buffer + (string-match-p "^ticks" (buffer-string))))) + (accept-process-output flan--connection 0.05))) + (test-flan--check "the table arrives without being asked for" + (with-current-buffer flan-watch-buffer + (string-match-p "^ticks [0-9]+" (buffer-string)))) + ;; `ticks' moves every frame, so every push is a new table. + (setq pushes 0) + (let ((until (+ (float-time) 1.0))) + (while (< (float-time) until) + (accept-process-output flan--connection 0.02))) + (test-flan--check + (format "and keeps arriving at the repaint interval (%d in 1s)" pushes) + (<= 2 pushes 8))) + (advice-remove 'flan-watch--absorb count)))) + ;; Replies are not disturbed by the pushes around them. + (test-flan--check "a request while the table is being pushed gets its own reply" (member "step" (plist-get (flan--request '(:op "describe")) :fns))) - ;; And the same hook against a daemon restarted under an armed watch. The - ;; reply the watch is owed was asked for on the connection that has gone, so - ;; there is nothing to wait for — running the hook before the connection is - ;; checked is what lets it see that. Asking after the reconnect meant a - ;; whole `flan-reply-timeout' of frozen Emacs on the first thing anybody - ;; typed after a restart, which is why the wait itself is what is measured. - (flan-watch--tick) + ;; A daemon restarted under an armed watch: the new connection arms it again. (delete-process flan--connection) - ;; The timeout and the assertion are deliberately different numbers: what is - ;; being told apart is a request that waited one out from a request that did - ;; not, and the wider the gap the less this depends on how loaded the machine - ;; running the suite happens to be. A reconnect and a `describe' are - ;; milliseconds of work. - (let ((flan-reply-timeout 10) - (started (float-time))) - (let ((r (flan--request '(:op "describe")))) - (test-flan--check "a request after a restart does not wait out a reply the old connection owed" - (and (member "step" (plist-get r :fns)) - (< (- (float-time) started) 3))) - (test-flan--check "and the watch is not left waiting for one either" - (null flan-watch--pending)))) - ;; A request in flight again, for the interleaving below. - (flan-watch--tick) - ;; And now the interleaving, with a reply outstanding on purpose. If the - ;; settle hook were not there this would return the watch table's plist and - ;; `flan--report' would take its missing :status for a rejection. - ;; + (let ((r (flan--request '(:op "describe")))) + (test-flan--check "after a reconnect the request is answered" + (member "step" (plist-get r :fns)))) + (with-current-buffer flan-watch-buffer + (let ((inhibit-read-only t)) (erase-buffer))) + (let ((until (+ (float-time) 5))) + (while (and (< (float-time) until) + (not (with-current-buffer flan-watch-buffer + (string-match-p "^ticks" (buffer-string))))) + (accept-process-output flan--connection 0.05))) + (test-flan--check "and the table is pushed again on the new connection" + (with-current-buffer flan-watch-buffer + (string-match-p "^ticks" (buffer-string)))) ;; Back in the source buffer first: `flan-doc' and `flan-watch' above both ;; display buffers of their own, and C-c C-c reads the buffer it is run in. (pop-to-buffer (flan--buffer-visiting file)) @@ -1383,31 +1407,24 @@ already rely on it — so nothing here is a stand-in for the real thing." (search-forward "(defn step") (goto-char (match-beginning 0)) (let ((said (test-flan--said (flan-eval-defun)))) - (test-flan--check "an eval with a watch reply in flight still gets its own answer" - (and said (string-match-p "step" said))) - (test-flan--check "and the watch request was settled, not abandoned" - (null flan-watch--pending))) - (flan-watch--tick) - (flan-watch--tick) - (test-flan--check "and the buffer keeps painting afterwards" - (with-current-buffer flan-watch-buffer - (> (buffer-size) 0))) + (test-flan--check "an eval while the table is being pushed gets its own answer" + (and said (string-match-p "step" said)))) ;; Point survives a repaint. This is why `replace-buffer-contents' is used ;; rather than erase-and-insert: the latter would put the cursor back at the - ;; top of the buffer on every tick, which makes the one thing you want to do - ;; in a watch buffer — look at a line while the program runs — impossible. + ;; top of the buffer on every repaint, which makes the one thing you want to + ;; do in a watch buffer — look at a line while the program runs — impossible. (with-current-buffer flan-watch-buffer + (flan-watch--absorb '(:status "ok" :watch (("ticks" "1")) :overflow nil)) (goto-char (point-max)) (let ((where (point))) - (flan-watch--tick) - (flan-watch--tick) + (flan-watch--absorb '(:status "ok" :watch (("ticks" "2")) :overflow nil)) (test-flan--check "and point does not jump to the top on a repaint" (= (point) where)))) - (flan-watch-stop) - (test-flan--check "stopping cancels the timer" (null flan-watch--timer)) - (test-flan--check "and takes the settle hook off with it" - (not (memq #'flan-watch--settle flan-settle-hook))) + ;; Killing the buffer is how it is closed, and it disarms the table. (kill-buffer flan-watch-buffer) + (test-flan--check "killing the watch buffer ends the subscription" + (and (null flan-watch--consumers) + (not (memq #'flan-watch--on-push flan-push-functions)))) (flan-disconnect) (test-flan--check "disconnected" (not (process-live-p flan--connection))) diff --git a/lib/dev.ml b/lib/dev.ml index 543e719c..99b1751d 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -4019,6 +4019,13 @@ let handle t req = in disassemble t ~name ~form | None -> error "disassemble needs :name") + (* Whether this connection is written to without asking. [serve] keeps the + switch, since it belongs to the connection; see [pushing]. *) + | Some "push" -> + ok [ (match Wire.field req "on" with + (* Not [:push], which marks a frame as a push. *) + | Some { Form.v = Form.Sym "nil"; _ } | None -> ":pushing nil" + | Some _ -> ":pushing t") ] | Some "close" -> ok [] | Some op -> error ("unknown op: " ^ op) | None -> error "no :op" @@ -4084,6 +4091,136 @@ let reply_of_exn e = error ~loc:(Loc.to_string l) (message_of_exn e) | _ -> error (message_of_exn e) +(* ── Pushing to the editor ─────────────────────────────────────────── *) + +(* A connection that has sent [(:op "push" :on t)] is also written to without + asking: the program's output as it is printed, and the watch table while + this connection has it armed. Every other frame on the socket answers a + request, so a push is marked [:push] with its kind — ["output"] or + ["watch"] — and a client reads it apart from the reply it is waiting for. + + Opt-in, because a client that has not said it reads unsolicited frames + would take the first one as the answer to its next request. The raw-socket + tests and any other client keep one reply per request and nothing else. + + Output is coalesced: the first bytes after a quiet spell wait [push_settle] + for more, and no two output pushes are closer than [push_gap]. A program + printing every frame is then twenty frames a second on the socket rather + than sixty or two hundred, and a single line still lands within [push_gap]. + + A push never interleaves with a reply. The loop is one thread: while a + request is handled nothing is pushed, what the program prints meanwhile + stays in [t.out], and [with_output] puts it on that request's reply and + empties the buffer, so it is not pushed again afterwards. *) +let push_settle = 0.01 +let push_gap = 0.05 +let watch_interval_default = 0.2 + +type pushing = { + mutable on : bool; + mutable out_due : float option; (* when buffered output goes out *) + mutable last_out : float; + mutable watch_every : float option; (* armed by this connection *) + mutable watch_due : float; +} + +let bool_field req key = + match Wire.field req key with + | Some { Form.v = Form.Sym "nil"; _ } | None -> false + | Some _ -> true + +let float_field req key = + match Wire.field req key with + | Some { Form.v = Form.Float f; _ } -> Some f + | Some { Form.v = Form.Int i; _ } -> Some (Int64.to_float i) + | _ -> None + +(* A reply's fields, tagged as a push. [reply] is a plist [(:status ...)]. *) +let as_push kind reply = + "(:push " ^ Wire.quote kind ^ " " + ^ String.sub reply 1 (String.length reply - 1) + +(* Output has arrived since the last look: schedule a push for it. *) +let note_output p t now = + if p.on && p.out_due = None && Buffer.length t.out > 0 then + p.out_due <- Some (Float.max (now +. push_settle) (p.last_out +. push_gap)) + +(* Whether the client is taking what it is sent. An editor that has stopped + reading — busy, or suspended — must not stop this loop, which is also what + drains the program's pipe: while the socket will not take more, output + stays in [t.out] (bounded by [capacity]) and the table waits a turn. *) +let writable fd = + match Unix.select [] [ fd ] [] 0. with + | _, [], _ -> false + | _ -> true + | exception Unix.Unix_error (Unix.EINTR, _, _) -> false + +(* Something is due to be pushed. *) +let push_is_due p now = + p.on + && ((match p.out_due with Some d -> now >= d | None -> false) + || (p.watch_every <> None && now >= p.watch_due)) + +(* Send whatever is due, and say whether something due could not be sent + because the client is not reading. Raises [Unix_error] when the client has + gone. *) +let rec push_due p t fd now = + if not (push_is_due p now) then false + else if not (writable fd) then true + else begin push_now p t fd now; false end + +and push_now p t fd now = + (match p.out_due with + | Some due when p.on && now >= due -> + p.out_due <- None; + p.last_out <- now; + (match take t with + | "" -> () + | text -> + Wire.send fd (as_push "output" (ok [ ":output " ^ Wire.quote text ]))) + | _ -> ()); + match p.watch_every with + | Some every when p.on && now >= p.watch_due -> + p.watch_due <- now +. every; + (* Each push closes the numeric slots' accumulation window while the + program runs. A stopped program takes no samples, so its window is left + open and the numbers from the moment it stopped stay on the screen. *) + let stopped = match state t with Stopped _ -> true | _ -> false in + (* Sent whether or not it changed: ghost text is repainted from each push, + and a buffer scrolled into view while the program is stopped gets its + values from the next one. *) + Wire.send fd (as_push "watch" (watch_read t ~reset:(not stopped))) + | _ -> () + +(* How long the loop may block before a push is due; [-1.] is no limit, which + is what [Unix.select] takes a negative timeout to mean. *) +let push_wait p now = + if not p.on then -1. + else + let until = function Some d -> Float.max 0. (d -. now) | None -> -1. in + let a = until p.out_due + and b = until (Option.map (fun _ -> p.watch_due) p.watch_every) in + if a < 0. then b else if b < 0. then a else Float.min a b + +(* What a request changes about pushing on this connection. [push] is the + switch; [watch-enable] arms or disarms the table's push, at [:interval] + seconds, once the program has accepted it. *) +let push_request p req op reply = + match op with + | Some "push" -> p.on <- bool_field req "on" + | Some "watch-enable" when String.starts_with ~prefix:"(:status \"ok\"" reply -> + if bool_field req "on" then begin + let every = + match float_field req "interval" with + | Some f when f > 0. -> Float.max f push_gap + | _ -> watch_interval_default + in + p.watch_every <- Some every; + p.watch_due <- 0. + end + else p.watch_every <- None + | _ -> () + (* ── The loop ──────────────────────────────────────────────────────── *) (* One connection at a time. An editor is one client, evaluations are @@ -4094,7 +4231,33 @@ let reply_of_exn e = so [close] shuts the whole thing down rather than waiting for another connection nobody is going to make. *) let serve t fd = + let p = { on = false; out_due = None; last_out = 0.; watch_every = None; + watch_due = 0. } in + (* Between requests: push what is due, then wait for a request, for the + program's output, or for the next push, whichever comes first. The pipe + is drained here whether or not this client takes pushes, which is the + liveness requirement [drain] describes, met while an editor is attached + as well as between editors. *) let rec go () = + match push_due p t fd (Unix.gettimeofday ()) with + | exception Unix.Unix_error _ -> false + | blocked -> + let fds = if t.finished then [ fd ] else [ fd; t.stdout ] in + (* A push the client is not taking waits for it to become writable + rather than spinning on a deadline that has already passed. *) + let wfds, wait = + if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ()) + in + (match Unix.select fds wfds [] wait with + | ready, _, _ -> + if List.mem t.stdout ready && not t.finished then begin + drain t; + note_output p t (Unix.gettimeofday ()) + end; + if List.mem fd ready then request () else go () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> go () + | exception Unix.Unix_error _ -> false) + and request () = match Wire.recv fd with | src -> (* One of the two places the agent clock is read — see [agent_check]. @@ -4125,6 +4288,9 @@ let serve t fd = | r -> r | exception e when not (fatal e) -> reply_of_exn e) in + (match parsed with + | Either.Left req -> push_request p req op reply + | Either.Right _ -> ()); (* The two annotations are inside the boundary as well, and not because they are likely to raise: [with_break] asks the program for its state and [with_output] drains its pipe, so they touch the same things the diff --git a/test/test_dev.ml b/test/test_dev.ml index 28c6c6cc..76a7ef55 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -4046,6 +4046,29 @@ let () = | Some v -> v <> first | None -> false)) then fail "the watch table stopped moving"; + (* Pushed, on a connection that asked for pushes: the table arrives + with nothing sent for it, marked as a push so a client can tell it + from a reply. *) + if Wire.string_field (ask "(:op \"push\" :on t)") "status" <> Some "ok" + then fail "push was refused"; + Wire.send wc "(:op \"watch-enable\" :on t :interval 0.05)"; + let rec reply () = + let f = Wire.parse (Wire.recv wc) in + if Wire.field f "push" = None then f else reply () + in + if Wire.string_field (reply ()) "status" <> Some "ok" then + fail "watch-enable with an interval was refused"; + (match Unix.select [ wc ] [] [] 5.0 with + | [], _, _ -> fail "no watch push arrived after arming" + | _ -> + let f = Wire.parse (Wire.recv wc) in + if Wire.string_field f "push" <> Some "watch" then + fail "the first frame after arming was not a watch push"; + (match Wire.field f "watch" with + | Some { Form.v = Form.List (_ :: _); _ } -> () + | _ -> fail "a watch push carried no table")); + Wire.send wc "(:op \"push\" :on nil)"; + ignore (reply ()); (* And off again. The value already in a slot stays — nothing clears it — but the program stops writing, so it stops changing. *) if status (ask "(:op \"watch-enable\" :on nil)") <> "ok" then From 20fa04d9df2f016a127973a92f1074de7c0ce3a0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:42:54 +0700 Subject: [PATCH 2/2] A program never waits on an editor that stops reading its pushes, and the editor keeps a bounded tail of the program's output --- docs/BUILT.md | 12 +++- emacs/MANUAL.md | 1 + emacs/flan-repl.el | 3 +- emacs/flan-watch.el | 2 +- emacs/flan.el | 20 +++++- emacs/test-flan-watch.el | 14 ++++ emacs/test-flan.el | 41 +++++++----- lib/dev.ml | 139 +++++++++++++++++++++++++-------------- test/test_dev.ml | 59 +++++++++++++++++ 9 files changed, 216 insertions(+), 75 deletions(-) diff --git a/docs/BUILT.md b/docs/BUILT.md index fb308bf0..8d646bd9 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -2462,9 +2462,15 @@ hundred, and a single line still arrives within 50ms. `capacity` still bounds wh **A push never lands inside a reply.** `serve` is one thread, so nothing is pushed while a request is handled; what the program prints meanwhile stays in `t.out`, `with_output` puts it on that request's reply and empties the buffer, and it is not pushed a second time. The stdout pipe is also drained now while an editor sits idle, which it was not: -`Wire.recv` blocked, so an attached, quiet editor let the pipe fill until its next request. A push goes out only when -the socket is writable; an editor that has stopped reading holds pushes back rather than stalling the loop, and its -output waits in `t.out`. +`Wire.recv` blocked, so an attached, quiet editor let the pipe fill until its next request. **The program never waits on +the editor.** A push is written without blocking from a per-connection buffer, and nothing new is framed while that +buffer holds bytes the socket would not take — so an editor that stops reading, even partway through a frame, holds +back one frame and no more. What the program prints meanwhile goes on being drained into `t.out`, which keeps its last +256K and drops the oldest bytes; `take` then puts a line in the output saying how many were dropped. Only a reply is +written blocking, after the buffer has been flushed ahead of it, because the editor asked for it and is reading. + +**The editor's side is bounded too.** `*flan*` and the REPL keep `flan-output-maximum-lines` (5000) and delete from the +top, as `comint-buffer-maximum-size` does, so a program that prints every frame cannot grow Emacs without limit. **The watch table moved onto the same channel.** `watch-enable` with `:interval` arms a push of the table from the same loop, sent every interval whether or not it changed, because ghost text is repainted from each one. The editor's watch timer, its in-flight flag and diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 922ec2c0..471d5dc3 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1206,6 +1206,7 @@ in the buffer). | `flan-names-shown` | `4` | how many names to list before summarising | | `flan-poll-interval` | `1.0` | seconds between checks for whether it stopped | | `flan-daemon-buffer` | `"*flan*"` | the daemon's own log; mirrors program output | +| `flan-output-maximum-lines` | `5000` | lines `*flan*` and the REPL keep; older ones are deleted | | `flan-diagnostics-buffer` | `"*flan-diagnostics*"` | everything the compiler reports, kept | | `flan-start-timeout` | `60` | seconds to wait for a program to come up | | `flan-lower-buffer` | `"*flan-lowering*"` | where `C-c C-l` writes | diff --git a/emacs/flan-repl.el b/emacs/flan-repl.el index f3b3c6e3..0f6e8721 100644 --- a/emacs/flan-repl.el +++ b/emacs/flan-repl.el @@ -273,7 +273,8 @@ prompt's line, so the prompt and whatever is being typed at it do not move." ;; text — a plain marker does not advance — and the value the ;; reply carries would then land above the output it caused. (when (>= at (marker-position mark)) - (set-marker mark (point))))))))) + (set-marker mark (point))))) + (flan--trim-lines))))) (defun flan-repl--buffer () "The REPL buffer, for the two clear commands, from wherever they are run." diff --git a/emacs/flan-watch.el b/emacs/flan-watch.el index 66db28eb..d0701a0a 100644 --- a/emacs/flan-watch.el +++ b/emacs/flan-watch.el @@ -355,7 +355,7 @@ Guarded on the row's length so a short name cannot be claimed by accident." (format "error:\n%s\n" (or (plist-get reply :message) "refused")))))) ;; The daemon sends the table on the connection every `flan-watch-interval' -;; while it is armed and has changed, the same way it sends the program's +;; while it is armed, changed or not, the same way it sends the program's ;; output. Nothing here sends a request on a timer, so nothing here can leave ;; a reply in flight for another request to read. ;; diff --git a/emacs/flan.el b/emacs/flan.el index fe109e33..0f60efd1 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -397,6 +397,21 @@ Pushes that arrive first are handled as they come." (bound-and-true-p flan-repl-buffer) (get-buffer flan-repl-buffer))) +(defcustom flan-output-maximum-lines 5000 + "Lines the daemon's buffer and the REPL keep; older lines are deleted. +A program that prints every frame would otherwise grow them without limit. +nil keeps everything." + :type '(choice integer (const :tag "No limit" nil))) + +(defun flan--trim-lines () + "Delete lines from the top of this buffer past `flan-output-maximum-lines'." + (when flan-output-maximum-lines + (save-excursion + (goto-char (point-max)) + (when (zerop (forward-line (- flan-output-maximum-lines))) + (let ((inhibit-read-only t)) + (delete-region (point-min) (line-beginning-position))))))) + (defun flan--append-output (text) "Append TEXT, the running program's own output, where it can be read. Two places. The daemon's log always gets it, so output lands somewhere @@ -409,6 +424,7 @@ open, above its prompt, which is where whoever is typing there is looking." (save-excursion (goto-char (point-max)) (insert text)) + (flan--trim-lines) ;; Follow the tail only for someone who was already at it; a reader ;; scrolled back is reading something. (when at-end (goto-char (point-max))))) @@ -1535,8 +1551,8 @@ no longer wrong." ;; The bare keys grep-mode and compilation-mode readers reach for. The ;; minor mode below provides RET, M-g M-n and M-g M-p; these two are the ;; major-mode half, possible because the buffer is read-only. - (define-key map (kbd "n") #'compilation-next-error) - (define-key map (kbd "p") #'compilation-previous-error) + (define-key map (kbd "n") #'next-error-no-select) + (define-key map (kbd "p") #'previous-error-no-select) ;; The minor mode's RET and `special-mode-map''s q, bound here as well so ;; that they are this mode's own keys and reach Evil's states. (define-key map (kbd "RET") #'compile-goto-error) diff --git a/emacs/test-flan-watch.el b/emacs/test-flan-watch.el index 8c43156f..ef4db654 100644 --- a/emacs/test-flan-watch.el +++ b/emacs/test-flan-watch.el @@ -272,5 +272,19 @@ what bounds its cost; a `with-temp-buffer' would be scanned by nothing." (delete-process proc) (kill-buffer buf))) +;; The daemon's buffer keeps `flan-output-maximum-lines' and loses the oldest. +(let ((flan-daemon-buffer " *flan-trim-test*") + (flan-output-maximum-lines 10)) + (unwind-protect + (progn + (dotimes (i 30) (flan--append-output (format "line %d\n" i))) + (with-current-buffer flan-daemon-buffer + (test-flan--check "the daemon's buffer is kept to its line limit" + (<= (count-lines (point-min) (point-max)) 10)) + (test-flan--check "and keeps the newest lines" + (and (string-match-p "line 29" (buffer-string)) + (not (string-match-p "line 0\n" (buffer-string))))))) + (kill-buffer flan-daemon-buffer))) + (provide 'test-flan-watch) ;;; test-flan-watch.el ends here diff --git a/emacs/test-flan.el b/emacs/test-flan.el index ab876b60..762551ed 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -557,20 +557,29 @@ already rely on it — so nothing here is a stand-in for the real thing." (accept-process-output flan--connection 0.01) (setq seen (with-current-buffer flan-daemon-buffer (string-match-p "HELLO" (buffer-string))))) - (let ((took (- (float-time) started))) - (test-flan--check "the program's output reaches the daemon's buffer" seen) - (test-flan--check - (format "without a request, in well under a second (%.3fs)" took) - (and seen (< took 0.3)))) - ;; The program prints every 5ms. Coalesced, a second of that is at - ;; most one push per 50ms, not two hundred. + ;; Arrival is the claim; the time is printed, not asserted, so a + ;; loaded machine running the suite in parallel cannot fail it. + (test-flan--check + (format "the program's output reaches the daemon's buffer without a request (%.3fs)" + (- (float-time) started)) + seen) + ;; The program prints every 5ms. Coalesced, the daemon sends at + ;; most one push per 50ms however fast it prints; a slow machine + ;; can only make that number smaller, so only the upper bound is + ;; asserted, and that pushes keep coming at all. (setq pushes 0) (let ((until (+ (float-time) 1.0))) (while (< (float-time) until) (accept-process-output flan--connection 0.02))) - (test-flan--check - (format "a burst of output is coalesced (%d pushes in 1s)" pushes) - (<= 5 pushes 25))) + (let ((in-window pushes) + (until (+ (float-time) 10))) + (while (and (< pushes (1+ in-window)) (< (float-time) until)) + (accept-process-output flan--connection 0.05)) + (test-flan--check + (format "a burst of output is coalesced (%d pushes in 1s)" in-window) + (<= in-window 25)) + (test-flan--check "and output keeps being pushed" + (> pushes in-window)))) (advice-remove 'flan--dispatch-push count) (flan--start-polling))) ;; A request made while the program prints still gets its own reply. @@ -1393,14 +1402,12 @@ already rely on it — so nothing here is a stand-in for the real thing." (test-flan--check "the table arrives without being asked for" (with-current-buffer flan-watch-buffer (string-match-p "^ticks [0-9]+" (buffer-string)))) - ;; `ticks' moves every frame, so every push is a new table. + ;; And again, unasked, rather than once. (setq pushes 0) - (let ((until (+ (float-time) 1.0))) - (while (< (float-time) until) - (accept-process-output flan--connection 0.02))) - (test-flan--check - (format "and keeps arriving at the repaint interval (%d in 1s)" pushes) - (<= 2 pushes 8))) + (let ((until (+ (float-time) 10))) + (while (and (< pushes 2) (< (float-time) until)) + (accept-process-output flan--connection 0.05))) + (test-flan--check "and keeps arriving" (>= pushes 2))) (advice-remove 'flan-watch--absorb count)))) ;; Replies are not disturbed by the pushes around them. (test-flan--check "a request while the table is being pushed gets its own reply" diff --git a/lib/dev.ml b/lib/dev.ml index 387a01cf..dd6c6fbe 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -68,6 +68,10 @@ type t = { A signal here is a crash, and a crash keeps [dir] on disk: see [remove_session_dirs]. *) mutable died : Unix.process_status option; + (* Bytes of program output dropped from the front of [out] because it grew + past [capacity] before anything read it. Said once, in the output, by + [take]. *) + mutable dropped : int; } (* The program's stdout is a pipe into this process, so that an editor can see @@ -97,6 +101,7 @@ let drain t = (* Bounded: a program that prints every frame must not grow this process without limit. The newest text is the useful end. *) if Buffer.length t.out > capacity then begin + t.dropped <- t.dropped + (Buffer.length t.out - capacity); let keep = Buffer.sub t.out (Buffer.length t.out - capacity) capacity in Buffer.clear t.out; Buffer.add_string t.out keep @@ -112,7 +117,14 @@ let take t = drain t; let s = Buffer.contents t.out in Buffer.clear t.out; - s + if t.dropped = 0 then s + else begin + let n = t.dropped in + t.dropped <- 0; + Printf.sprintf + "[flan dev: %d bytes of the program's output were dropped; the editor \ + was not reading fast enough]\n%s" n s + end let await ?(ms = 5000) f = let rec go ms = @@ -4288,7 +4300,17 @@ let reply_of_exn e = A push never interleaves with a reply. The loop is one thread: while a request is handled nothing is pushed, what the program prints meanwhile stays in [t.out], and [with_output] puts it on that request's reply and - empties the buffer, so it is not pushed again afterwards. *) + empties the buffer, so it is not pushed again afterwards. + + The program never waits on the editor. A push is written without blocking + from [pend], and whatever the socket will not take stays there until it is + writable again; nothing new is framed while [pend] holds anything. So an + editor that stops reading, even partway through a frame, costs at most one + frame here, and what the program prints in the meantime piles up in + [t.out], which [drain] keeps to [capacity] by dropping the oldest bytes. + [take] then says in the output how much was dropped. Only a reply is + written blocking, after [pend] has been flushed ahead of it: the editor + asked for it and is reading. *) let push_settle = 0.01 let push_gap = 0.05 let watch_interval_default = 0.2 @@ -4299,6 +4321,8 @@ type pushing = { mutable last_out : float; mutable watch_every : float option; (* armed by this connection *) mutable watch_due : float; + pend : Buffer.t; (* framed bytes not yet written *) + mutable sent : int; (* how many of [pend] have been *) } let bool_field req key = @@ -4322,52 +4346,64 @@ let note_output p t now = if p.on && p.out_due = None && Buffer.length t.out > 0 then p.out_due <- Some (Float.max (now +. push_settle) (p.last_out +. push_gap)) -(* Whether the client is taking what it is sent. An editor that has stopped - reading — busy, or suspended — must not stop this loop, which is also what - drains the program's pipe: while the socket will not take more, output - stays in [t.out] (bounded by [capacity]) and the table waits a turn. *) -let writable fd = - match Unix.select [] [ fd ] [] 0. with - | _, [], _ -> false - | _ -> true - | exception Unix.Unix_error (Unix.EINTR, _, _) -> false +let pending p = Buffer.length p.pend > p.sent -(* Something is due to be pushed. *) -let push_is_due p now = - p.on - && ((match p.out_due with Some d -> now >= d | None -> false) - || (p.watch_every <> None && now >= p.watch_due)) +let frame p payload = + Buffer.add_string p.pend (string_of_int (String.length payload)); + Buffer.add_char p.pend '\n'; + Buffer.add_string p.pend payload -(* Send whatever is due, and say whether something due could not be sent - because the client is not reading. Raises [Unix_error] when the client has - gone. *) -let rec push_due p t fd now = - if not (push_is_due p now) then false - else if not (writable fd) then true - else begin push_now p t fd now; false end +(* Write as much of [pend] as the socket takes now. With [~block] the rest is + waited for, which only a reply about to follow it asks. Raises [Unix_error] + when the client has gone. *) +let flush_pend ?(block = false) p fd = + if pending p then begin + let data = Buffer.contents p.pend in + let n = String.length data in + if not block then Unix.set_nonblock fd; + Fun.protect ~finally:(fun () -> if not block then Unix.clear_nonblock fd) + (fun () -> + let rec go () = + if p.sent < n then + match Unix.single_write_substring fd data p.sent (n - p.sent) with + | k -> p.sent <- p.sent + k; go () + | exception Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) + -> () + in + go ()); + if p.sent >= n then begin Buffer.clear p.pend; p.sent <- 0 end + end -and push_now p t fd now = - (match p.out_due with - | Some due when p.on && now >= due -> - p.out_due <- None; - p.last_out <- now; - (match take t with - | "" -> () - | text -> - Wire.send fd (as_push "output" (ok [ ":output " ^ Wire.quote text ]))) - | _ -> ()); - match p.watch_every with - | Some every when p.on && now >= p.watch_due -> - p.watch_due <- now +. every; - (* Each push closes the numeric slots' accumulation window while the - program runs. A stopped program takes no samples, so its window is left - open and the numbers from the moment it stopped stay on the screen. *) - let stopped = match state t with Stopped _ -> true | _ -> false in - (* Sent whether or not it changed: ghost text is repainted from each push, - and a buffer scrolled into view while the program is stopped gets its - values from the next one. *) - Wire.send fd (as_push "watch" (watch_read t ~reset:(not stopped))) - | _ -> () +(* Frame whatever is due, if nothing is still waiting to be written, and write + what the socket will take. Answers whether bytes are left waiting for the + socket to become writable. *) +let push_due p t fd now = + if p.on && not (pending p) then begin + (match p.out_due with + | Some due when now >= due -> + p.out_due <- None; + p.last_out <- now; + (match take t with + | "" -> () + | text -> + frame p (as_push "output" (ok [ ":output " ^ Wire.quote text ]))) + | _ -> ()); + match p.watch_every with + | Some every when now >= p.watch_due -> + p.watch_due <- now +. every; + (* Each push closes the numeric slots' accumulation window while the + program runs. A stopped program takes no samples, so its window is + left open and the numbers from the moment it stopped stay on the + screen. *) + let stopped = match state t with Stopped _ -> true | _ -> false in + (* Sent whether or not it changed: ghost text is repainted from each + push, and a buffer scrolled into view while the program is stopped + gets its values from the next one. *) + frame p (as_push "watch" (watch_read t ~reset:(not stopped))) + | _ -> () + end; + flush_pend p fd; + pending p (* How long the loop may block before a push is due; [-1.] is no limit, which is what [Unix.select] takes a negative timeout to mean. *) @@ -4409,7 +4445,7 @@ let push_request p req op reply = connection nobody is going to make. *) let serve t fd = let p = { on = false; out_due = None; last_out = 0.; watch_every = None; - watch_due = 0. } in + watch_due = 0.; pend = Buffer.create 4096; sent = 0 } in (* Between requests: push what is due, then wait for a request, for the program's output, or for the next push, whichever comes first. The pipe is drained here whether or not this client takes pushes, which is the @@ -4420,8 +4456,9 @@ let serve t fd = | exception Unix.Unix_error _ -> false | blocked -> let fds = if t.finished then [ fd ] else [ fd; t.stdout ] in - (* A push the client is not taking waits for it to become writable - rather than spinning on a deadline that has already passed. *) + (* Bytes the client has not taken wait for it to become writable; no + deadline applies meanwhile, since nothing new is framed until they + have gone. *) let wfds, wait = if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ()) in @@ -4485,7 +4522,7 @@ let serve t fd = here went straight past the two below and out of the accept loop, ending the session. An editor that left before its reply arrived is a closed connection and nothing more, which is what [false] says. *) - (match Wire.send fd annotated with + (match flush_pend ~block:true p fd; Wire.send fd annotated with | () -> if op = Some "close" then true else go () | exception Unix.Unix_error _ -> false) | exception Wire.Closed -> false @@ -4815,7 +4852,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = { session; child = Some child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; host_ll; host_exe = exe; finished = false; agent_watch = None; - park_noted = false; died = None } + park_noted = false; died = None; dropped = 0 } in ignore_sigpipe (); (try Unix.unlink sock with Unix.Unix_error _ -> ()); @@ -5657,7 +5694,7 @@ let merged_setup () = { session; child = None; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; host_ll; host_exe = exe; finished = false; agent_watch = None; - park_noted = false; died = None } + park_noted = false; died = None; dropped = 0 } in ignore_sigpipe (); (try Unix.unlink sock with Unix.Unix_error _ -> ()); diff --git a/test/test_dev.ml b/test/test_dev.ml index eadfe160..e2457655 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -3925,6 +3925,65 @@ let () = fail "the evaluation drained the program's pipe and kept none of it, so \ the output it caused is gone"); + (* An editor that takes pushes and then stops reading partway through + one must not stop the program. The daemon writes pushes without + blocking, so the program keeps printing into a bounded buffer whose + oldest bytes are dropped, and a line in the output says so. Progress + is the [frames] counter, read before and after a stall long enough + that a blocked program would have filled every buffer between it and + this socket many times over. *) + let rec reply () = + let f = Wire.parse (Wire.recv c) in + if Wire.field f "push" = None then f else reply () + in + let frames_now () = + Wire.send c + "(:op \"eval-expr\" :code \"frames\" :file \"/tmp/chatty.flan\")"; + match Wire.string_field (reply ()) "value" with + | Some v -> Option.value ~default:(-1) (int_of_string_opt v) + | None -> -1 + in + Wire.send c "(:op \"push\" :on t)"; + ignore (reply ()); + let f0 = frames_now () in + (* Into the next push's body and no further. *) + let one = Bytes.create 1 in + let rec header acc = + match Unix.read c one 0 1 with + | 1 when Bytes.get one 0 = '\n' -> int_of_string acc + | 1 -> header (acc ^ Bytes.to_string one) + | _ -> raise Wire.Closed + in + let n = header "" in + let part = Wire.read_exactly c (min 16 n) in + ignore part; + ignore (Unix.select [] [] [] 3.0); + ignore (Wire.read_exactly c (n - min 16 n)); + (* Everything after the stall, until the reply to this count, is read + for the note about what was dropped. *) + Wire.send c + "(:op \"eval-expr\" :code \"frames\" :file \"/tmp/chatty.flan\")"; + let noted = ref false in + let rec count () = + let f = Wire.parse (Wire.recv c) in + (match Wire.string_field f "output" with + | Some o when contains_sub o "were dropped" -> noted := true + | _ -> ()); + if Wire.field f "push" = None then f else count () + in + let f1 = + match Wire.string_field (count ()) "value" with + | Some v -> Option.value ~default:(-1) (int_of_string_opt v) + | None -> -1 + in + if f0 < 0 || f1 < 0 then fail "the frame counter could not be read" + else if f1 - f0 < 400 then + fail "an editor that stopped reading mid-push held the program to %d \ + frames in 3s" (f1 - f0); + if not !noted then + fail "output dropped while the editor was not reading was not reported"; + Wire.send c "(:op \"push\" :on nil)"; + ignore (reply ()); ignore (request c "(:op \"close\")"); (try Unix.close c with Unix.Unix_error _ -> ()); if not