JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 11:16:49 +07:00
parent bf827dc55b
commit f4725788c5
14 changed files with 759 additions and 397 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
TODO.org
View File

@ -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 slot type, and whether an untyped slot stays legal (it should — =dyn= is a type
and writing nothing should mean it). and writing nothing should mean it).
** NEXT println takes up to a second to appear ** DONE 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. CLOSED: [2026-09-25]
Output is drained by =flan--poll= at =flan-poll-interval=, 1.0s The daemon pushes program output on a connection that asked for pushes
(=emacs/flan.el:541=). A reply carries whatever was buffered when it was (=(:op "push" :on t)=), coalesced to at most one frame per 50ms, and the
composed, so anything the program prints after that waits for the next tick. watch table on the same channel at =flan-watch-interval=. Emacs reads every
Polling faster costs a request a second for nothing most of the time; the frame in a process filter. The editor's watch timer and =flan-settle-hook=
daemon pushing on its own connection is the other shape. Decide which. 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 ** NEXT set writes a class slot; put is for maps
Decided 2026-09-25: as written; one lane with typed slots. 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, binds, stays Evil's. The other special-mode buffers (inspect, watch, doc, disassembly,
diagnostics, lower) have the same exposure and are not changed. diagnostics, lower) have the same exposure and are not changed.
** NEXT Evil takes the keys in the other Flan buffers ** DONE Evil takes the keys in the other Flan buffers
The inspect, watch, doc, disassembly, diagnostics and lower buffers get the break CLOSED: [2026-09-25]
buffer's treatment: the keys each binds itself go to Evil's normal and motion =flan-evil-own-keys= (flan-mode.el) gives the keys a mode's own map binds to
states, and every other key stays Evil's. Bindings stay as close as possible Evil's normal and motion states; the break, inspect, watch, doc, disassembly,
between Evil and Emacs states. 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 ** NEXT Eval in the frame, from the break loop
Decided 2026-09-25: SLIME's eval-in-frame, as described. Decided 2026-09-25: SLIME's eval-in-frame, as described.

72
docs/BUILT.md
View File

@ -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 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 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. 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 - **And a timer asks anyway**, once a second, with `describe` — the cheap op. (It used to be how the program's output
drained. A program that stops in a frame of its own game loop produces no reply at all, and folding state into replies 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 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 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 `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` 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. 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 ### `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. `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 **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 that paints the buffer, from the same push, so the two cannot disagree. What had to change is that the **watch
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 disarmed the table. That was right while it was the only consumer and
buffer used to be the subscription**: killing it cancelled the timer and disarmed the table. That was right while it wrong the moment it was not, so arming hangs off `flan-watch--consumers`, and only the last consumer out turns the
was the only consumer and wrong the moment it was not, so arming and the timer now hang off lights 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 **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 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 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 `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 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 tool exists to show you a number while you drag the mouse. So each push of the table resets after its read and the
the displayed range is "since you last looked" — a fifth of a second, a dozen frames. A caller that wants the displayed range is "since you last looked" — a fifth of a second, a dozen frames. A caller of the `watch` op that
cumulative numbers gets them by not resetting; the setting lives in the editor, not in the runtime. 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 **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 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 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 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 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 and was a reset sent five times a second at a program that could not answer it. So the reset is guarded on the
answer it. So the reset is now guarded on `flan--stopped` — the read still goes out every tick, only the reset program being stopped — the table is still read and pushed, only the reset is skipped — and the runtime is untouched.
field drops — and the runtime is untouched. That keeps the policy where the rest of this section already put it: The guard was the editor's while the editor polled the table; it is `push_due`'s in `dev.ml` now that the daemon
"since you last looked" is the editor's idea, not the table's. `watch_render_num`'s unreachable `n=0` arm is deleted 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 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. invitation to add one.

17
emacs/MANUAL.md
View File

@ -291,8 +291,10 @@ that is what the program calls it.
form rides along on the reply and is inserted above the prompt — output 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 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 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 itself is in that buffer, which pops up. What the program prints on its own,
all program output, so a println is never lost when no prompt is open. 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 **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 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. 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 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 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 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 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 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 `flan-watch-ghost-call-regexp` — the Flan name is yours, and only the C symbol
behind it is fixed. behind it is fixed.
**When it updates.** On the same timer as the buffer, from the same reply, so **When it updates.** Each time the daemon sends the table, from the same frame
the two cannot disagree. As with the buffer, the interval decides how often the 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 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 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. 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`. **One name, two call sites.** Both show it, and both say `one slot, 2 sites`.

20
emacs/flan-cnr.el
View File

@ -64,6 +64,7 @@
(require 'seq) (require 'seq)
(require 'subr-x) (require 'subr-x)
(require 'flan-mode)
(declare-function flan--request "flan" (form)) (declare-function flan--request "flan" (form))
(declare-function flan-visit-loc "flan" (loc subject)) (declare-function flan-visit-loc "flan" (loc subject))
@ -832,22 +833,9 @@ anyone who would rather TAB always moved."
"Keys in `flan-cnr-mode'.") "Keys in `flan-cnr-mode'.")
;; Evil's normal state binds 0, the other digits and RET above any major ;; 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 ;; mode's map, so under Evil a digit would move point or start a count and
;; nothing. The keys this file binds are given to Evil's normal and motion ;; take nothing. See `flan-evil-own-keys'.
;; states in this mode. Only those keys: `flan-cnr-mode-map' inherits (flan-evil-own-keys 'flan-cnr-mode-map)
;; `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))))))
(define-derived-mode flan-cnr-mode special-mode "flan-break" (define-derived-mode flan-cnr-mode special-mode "flan-break"
"What a stopped Flan program is offering." "What a stopped Flan program is offering."

3
emacs/flan-inspect.el
View File

@ -99,6 +99,7 @@
(require 'cl-lib) (require 'cl-lib)
(require 'seq) (require 'seq)
(require 'subr-x) (require 'subr-x)
(require 'flan-mode)
(declare-function flan--request "flan" (form)) (declare-function flan--request "flan" (form))
@ -1280,6 +1281,8 @@ the kind of thing nobody reports and everybody notices."
map) map)
"Keys in `flan-inspect-mode'.") "Keys in `flan-inspect-mode'.")
(flan-evil-own-keys 'flan-inspect-mode-map)
(define-derived-mode flan-inspect-mode special-mode "flan-inspect" (define-derived-mode flan-inspect-mode special-mode "flan-inspect"
"Look at a value in the running Flan program." "Look at a value in the running Flan program."
(setq buffer-read-only t) (setq buffer-read-only t)

2
emacs/flan-lower.el
View File

@ -571,6 +571,8 @@ that is felt."
map) map)
"Keys in `flan-lower-mode'.") "Keys in `flan-lower-mode'.")
(flan-evil-own-keys 'flan-lower-mode-map)
(define-derived-mode flan-lower-mode special-mode "flan-lower" (define-derived-mode flan-lower-mode special-mode "flan-lower"
"Every lowering of one Flan function, in foldable sections. "Every lowering of one Flan function, in foldable sections.

33
emacs/flan-mode.el
View File

@ -776,5 +776,38 @@ decision to `calculate-lisp-indent'."
;;;###autoload ;;;###autoload
(add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode)) (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) (provide 'flan-mode)
;;; flan-mode.el ends here ;;; flan-mode.el ends here

208
emacs/flan-watch.el
View File

@ -47,20 +47,20 @@
;; halves are cheap for opposite reasons, and two things fall out that a poll ;; halves are cheap for opposite reasons, and two things fall out that a poll
;; could not have given: ;; could not have given:
;; ;;
;; the values update at *frame rate* rather than at the timer's rate — the ;; the values update at *frame rate* rather than at the repaint rate — the
;; timer only decides how often the picture is repainted, not how fresh it ;; interval only decides how often the picture is repainted, not how fresh
;; is; ;; it is;
;; ;;
;; and the last frame's values are still there while the program 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 ;; *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 ;; boundary, because there are no more frames, and precisely when you want to
;; see what the last one held. ;; see what the last one held.
;; ;;
;; Also kept from the original, and for its stated reasons: the request is ;; The daemon reads the table and sends it on the editor's connection, as it
;; **async**, because a synchronous call on a timer blocks Emacs's UI every ;; sends the program's output, so Emacs never waits on a timer for it. The
;; tick; and the paint is `replace-buffer-contents' rather than erase-and- ;; paint is `replace-buffer-contents' rather than erase-and-insert, because it
;; insert, because it diffs, so point and scroll survive a repaint instead of ;; diffs, so point and scroll survive a repaint instead of being yanked to the
;; being yanked to the top five times a second. ;; top five times a second.
;; ;;
;; What a program writes: ;; What a program writes:
;; ;;
@ -92,19 +92,17 @@
"Seconds between repaints. "Seconds between repaints.
This is the *repaint* rate, not the watch rate. The program writes its values 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 every frame whatever this is; all this decides is how often the daemon sends
refreshed, which is why a slow value here costs freshness and nothing else." 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) :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 (defvar flan-watch--rows nil
"The last table painted, as a list of (NAME . VALUE).") "The last table painted, as a list of (NAME . VALUE).")
(defvar flan-watch--consumers nil (defvar flan-watch--consumers nil
"Which pictures of the table are currently wanted: `buffer', `ghost', or both. "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 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 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 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 ;; 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. ;; table came from one of these call sites by construction.
;; ;;
;; WHEN IT UPDATES. On the same timer, from the same reply. The two pictures ;; WHEN IT UPDATES. On the same push, from the same frame. The two pictures
;; therefore cannot disagree — they are one table read, painted twice — and ;; therefore cannot disagree — they are one table read, painted twice. As
;; there is no second `:op "watch"' in flight, which is the invariant ;; with the buffer, the push interval decides how often the picture is
;; `flan-settle-hook' exists to keep. As with the buffer, the timer decides ;; repainted and not how fresh it is: the program writes every frame
;; how often the picture is repainted and not how fresh it is: the program ;; regardless.
;; writes every frame regardless.
;; ;;
;; Overlays are deleted and re-placed from scratch on every repaint rather than ;; 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 ;; 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) (overlay-put ov 'flan-watch-ghost t)
(push ov flan-watch--ghost-overlays)))))))))) (push ov flan-watch--ghost-overlays))))))))))
;;; The tick ;;; The push
(defun flan-watch--absorb (reply) (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) (pcase (plist-get reply :status)
("ok" ("ok"
(setq flan-watch--rows (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 (flan-watch--paint
(format "error:\n%s\n" (or (plist-get reply :message) "refused")))))) (format "error:\n%s\n" (or (plist-get reply :message) "refused"))))))
(defun flan-watch--settle () ;; The daemon sends the table on the connection every `flan-watch-interval'
"Collect an outstanding watch reply, blocking if it has not arrived. ;; 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 (defun flan-watch--on-push (kind frame)
timer's reply as its own. Blocking here is fine and blocking in the tick is "Paint FRAME when KIND says it is the watch table."
not: this runs inside something a person asked for, which already waits, and (when (and (equal kind "watch") flan-watch--consumers)
what it waits for is a table read with nothing compiled behind it." (flan-watch--absorb frame)))
(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--tick () (defun flan-watch--on-connect ()
"Collect the last reply if it has come, then ask again. Never blocks. "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 (defun flan-watch--on-disconnect ()
synchronous call on a 0.2s timer stalls Emacs's UI every tick, and a timer is "Say that the table is no longer live."
the one caller that must not. So this takes whatever has already arrived and (when flan-watch--consumers
sends the next question, leaving at most one request in flight — the invariant (flan-watch--ghost-clear)
`flan-settle-hook' exists to keep." (flan-watch--paint "error:\nnot connected to a running program\n")))
(cond
;; Killing the buffer cancels the buffer's half of the subscription, and (defun flan-watch--arm (on)
;; only that. When it was the only consumer this stops the timer and "Ask the daemon to arm the table and push it, or to disarm it when ON is nil."
;; disarms the table, so a program nobody is watching is back to paying a (flan--request (if on
;; load and a branch per watch call; when ghost text is also on, the table `(:op "watch-enable" :on t :interval ,flan-watch-interval)
;; stays armed and the ticks carry on feeding it. '(:op "watch-enable" :on nil))))
((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)))))))
;;; Commands ;;; 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" (define-derived-mode flan-watch-mode special-mode "flan-watch"
"Major mode for the pinned watch buffer." "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) (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 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 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." consumer: two of them looking at one table is still one table."
(flan--live-connection) (flan--live-connection)
(unless flan-watch--consumers (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") (unless (equal (plist-get r :status) "ok")
(user-error "flan: %s" (or (plist-get r :message) "watch refused"))))) (user-error "flan: %s" (or (plist-get r :message) "watch refused")))))
(unless (memq consumer flan-watch--consumers) (unless (memq consumer flan-watch--consumers)
(push consumer flan-watch--consumers)) (push consumer flan-watch--consumers))
(add-hook 'flan-settle-hook #'flan-watch--settle) (add-hook 'flan-push-functions #'flan-watch--on-push)
(when flan-watch--timer (cancel-timer flan-watch--timer)) (add-hook 'flan-connected-hook #'flan-watch--on-connect)
(setq flan-watch--timer (add-hook 'flan-disconnected-hook #'flan-watch--on-disconnect))
(run-with-timer 0 flan-watch-interval #'flan-watch--tick)))
(defun flan-watch--drop (consumer) (defun flan-watch--drop (consumer)
"Stop painting CONSUMER, and tear everything down if it was the last one." "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) (flan-watch--subscribe 'buffer)
(with-current-buffer (get-buffer-create flan-watch-buffer) (with-current-buffer (get-buffer-create flan-watch-buffer)
(unless (eq major-mode 'flan-watch-mode) (flan-watch-mode))) (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 ;; 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 ;; 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. ;; 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. ;; `flan-watch--drop' and back into here.
(setq flan-watch-ghost-mode nil) (setq flan-watch-ghost-mode nil)
(flan-watch--ghost-clear) (flan-watch--ghost-clear)
(when flan-watch--timer (remove-hook 'flan-push-functions #'flan-watch--on-push)
(cancel-timer flan-watch--timer) (remove-hook 'flan-connected-hook #'flan-watch--on-connect)
(setq flan-watch--timer nil)) (remove-hook 'flan-disconnected-hook #'flan-watch--on-disconnect)
;; Settle before disarming, or the disarm request reads the tick's reply. ;; Only on a connection that is already live. `flan--request' reconnects,
(flan-watch--settle) ;; which is right for something a person did and wrong here: there is
(remove-hook 'flan-settle-hook #'flan-watch--settle) ;; nothing to disarm when the connection has gone, because the table went
;; Only on a connection that is already live, and this is the important half. ;; with the program.
;; `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.
(when (process-live-p flan--connection) (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 ;;; What ghost text still cannot show

265
emacs/flan.el
View File

@ -244,44 +244,96 @@ to."
'utf-8 t))) 'utf-8 t)))
(process-send-string proc (format "%d\n%s" (length payload) payload)))) (process-send-string proc (format "%d\n%s" (length payload) payload))))
(defun flan--take-reply (proc) ;; Two kinds of frame arrive on the connection. A reply answers the request
"Read one complete framed message out of PROC's buffer, or return nil. ;; 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, (defvar flan-push-functions nil
split out for the watch timer: a timer that called `accept-process-output' "Functions called with each push from the daemon other than output.
would stall the UI every tick, which is exactly the mistake the Clojure Each is called with two arguments, the kind as a string (\"watch\") and the
original left a comment about. See `flan-watch--tick'." 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)) (when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc) (with-current-buffer (process-buffer proc)
(goto-char (point-min)) (let (frame)
(when (re-search-forward "\\`\\([0-9]+\\)\n" nil t) (while (setq frame (progn (goto-char (point-min))
(let* ((n (string-to-number (match-string 1))) (flan--next-frame)))
(body-start (point))) (let ((text (car frame)))
;; Present in full, or not yet — a partial body is not an error here, (if (string-prefix-p "(:push " text)
;; it is the ordinary state between the send and the reply. (condition-case nil
(when (>= (- (position-bytes (point-max)) (position-bytes body-start)) n) (flan--dispatch-push (car (read-from-string text)))
(flan--extract-reply body-start n))))))) ;; 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) (defun flan--next-frame ()
"Read the N bytes at BODY-START as a reply and delete the frame. "Remove the complete frame at point-min and return (TEXT), or return nil.
Point is in the process buffer, and the frame is known to be complete. 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 (defun flan--filter (proc string)
and the only reason this is worth a comment. A payload that will not read is "Append STRING to PROC's buffer and take off whatever frames are complete."
a bug at the other end, and the client's job is to report it once: reading (when (buffer-live-p (process-buffer proc))
first would leave those bytes at the head of the buffer, so the next request (with-current-buffer (process-buffer proc)
would read the same unreadable frame again, and every request after that — (goto-char (point-max))
one bad reply and the connection is wedged until Emacs is restarted. (insert string))
Consuming it first costs the reply, which was lost anyway, and leaves the (flan--collect proc)))
stream in step for the request that follows."
(let* ((end (byte-to-position (+ (position-bytes body-start) n))) (defun flan--take-reply (proc)
(text (decode-coding-string "The next reply PROC has sent, or nil if none has arrived. Never waits.
(encode-coding-string (buffer-substring-no-properties A reply that would not read signals here, having already been consumed."
body-start end) (flan--collect proc)
'utf-8 t) (let ((q (process-get proc 'flan-replies)))
'utf-8))) (when q
(delete-region (point-min) end) (process-put proc 'flan-replies (cdr q))
(car (read-from-string text)))) (pcase (car q)
(`(ok . ,reply) reply)
(`(bad . ,err) (signal (car err) (cdr err)))))))
(defun flan--no-reply (proc) (defun flan--no-reply (proc)
"Signal that PROC has not answered, saying which of the two silences it is. "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 "?"))))) (abbreviate-file-name (or flan--socket "?")))))
(defun flan--read-reply (proc) (defun flan--read-reply (proc)
"Block until PROC sends one complete framed message, and read it." "Block until PROC sends a reply, and return it.
(with-current-buffer (process-buffer proc) Pushes that arrive first are handled as they come."
(let ((deadline (+ (float-time) flan-reply-timeout))) (let ((deadline (+ (float-time) flan-reply-timeout))
;; The header first: digits up to a newline. (got nil) (reply nil))
(while (and (not (save-excursion (goto-char (point-min)) (while (and (not got) (< (float-time) deadline))
(re-search-forward "\\`\\([0-9]+\\)\n" nil t))) (if (process-get proc 'flan-replies)
(< (float-time) deadline)) (setq reply (flan--take-reply proc) got t)
(accept-process-output proc 0.05)) (flan--collect proc)
(goto-char (point-min)) (unless (process-get proc 'flan-replies)
;; Nothing is erased here, and that is the difference between the two (accept-process-output proc 0.05))))
;; deadlines. A header that has not arrived in full is a valid prefix (unless got
;; of a reply still on its way — throwing it away would turn a daemon (setq got (and (process-get proc 'flan-replies) t))
;; that is merely slow into a stream out of step by however much of the (when got (setq reply (flan--take-reply proc))))
;; count had landed. (unless got
(unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t) ;; A header whose body never came is a promise about bytes that will
(flan--no-reply proc)) ;; never be made good: reading on from here would take the *next*
(let* ((n (string-to-number (match-string 1))) ;; reply's header as this one's payload, and every request after it
(body-start (point))) ;; would be answered by the one before. The frame is dead, so it is
(while (and (< (- (position-bytes (point-max)) (position-bytes body-start)) n) ;; dropped. A header that has not arrived in full is left, being a
(< (float-time) deadline)) ;; valid prefix of a frame still on its way.
(accept-process-output proc 0.05)) (when (buffer-live-p (process-buffer proc))
(if (>= (- (position-bytes (point-max)) (position-bytes body-start)) n) (with-current-buffer (process-buffer proc)
(flan--extract-reply body-start n) (goto-char (point-min))
;; The body never came, so the count at the head of the buffer is a (when (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
;; promise about bytes that will never be made good: reading on from (erase-buffer))))
;; here would take the *next* reply's header as this one's payload (flan--no-reply proc))
;; and every request after it would be answered by the one before. reply))
;; 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))))))
;; Written by `flan--append-output' when a REPL is open; defined in ;; 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 ;; 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)))) (run-at-time 0 nil #'flan--auto-break))))
reply) 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) (defun flan--request (form)
"Send FORM to the connected program and return its reply." "Send FORM to the connected program and return its reply."
;; `flan--busy' first of all, and around the reconnect as well as around ;; `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 ;; middle of that would be a second conversation on the connection this one
;; just opened. ;; just opened.
(let ((flan--busy t)) (let ((flan--busy t))
(run-hooks 'flan-settle-hook)
(let ((proc (flan--live-connection))) (let ((proc (flan--live-connection)))
(flan--absorb (progn (flan--send proc form) (flan--absorb (progn (flan--send proc form)
(flan--read-reply proc)))))) (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) (let ((proc flan--connection)
(flan--busy t)) (flan--busy t))
(ignore-errors (ignore-errors
;; The same settle every other sender does, and for the same reason. ;; `describe' rather than `break': it is the cheap op, and the state
;; `flan--busy' is not enough on its own: the watch timer leaves a ;; is on every reply anyway. Asking `break' would fetch restart names
;; request in flight and *clears* nothing, deliberately — it binds no ;; nobody is choosing from. The program's output does not wait for
;; busy flag, because it never waits — so a poll that checked only the ;; this; the daemon pushes it as it is printed.
;; 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.
(flan--send proc '(:op "describe")) (flan--send proc '(:op "describe"))
(flan--absorb (flan--read-reply proc)))))) (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 (setq flan--connection
(make-network-process (make-network-process
:name "flan" :buffer buf :family 'local :service socket :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--socket socket))
(setq flan--stopped nil) (setq flan--stopped nil)
(setq flan--parked 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) (flan--start-polling)
(force-mode-line-update t) (force-mode-line-update t)
(run-hooks 'flan-connected-hook)
flan--connection) 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 ;; 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 ;; 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 ;; 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. ;; major-mode half, possible because the buffer is read-only.
(define-key map (kbd "n") #'compilation-next-error) (define-key map (kbd "n") #'compilation-next-error)
(define-key map (kbd "p") #'compilation-previous-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) map)
"Keymap for `flan-diagnostics-mode'.") "Keymap for `flan-diagnostics-mode'.")
(flan-evil-own-keys 'flan-diagnostics-mode-map)
(define-derived-mode flan-diagnostics-mode special-mode "Flan-Diagnostics" (define-derived-mode flan-diagnostics-mode special-mode "Flan-Diagnostics"
"Every message the compiler handed the editor, one navigable list. "Every message the compiler handed the editor, one navigable list.
`n' and `p' move between entries, RET goes to the line one names. `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*" (defvar flan-doc-buffer "*flan-doc*"
"Buffer `flan-doc' writes into.") "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" (define-derived-mode flan-doc-mode special-mode "Flan-Doc"
"Mode for the buffer `flan-doc' writes.") "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*" (defvar flan-disassembly-buffer "*flan-disassembly*"
"Buffer `flan-disassemble' writes into.") "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" (define-derived-mode flan-disassembly-mode special-mode "Flan-Disasm"
"Mode for the buffer `flan-disassemble' writes." "Mode for the buffer `flan-disassemble' writes."
(setq-local truncate-lines t)) (setq-local truncate-lines t))

34
emacs/test-flan-cider.el
View File

@ -1912,7 +1912,39 @@ stopped program, which is the case where it should fire."
("<" . evil-shift-left) ("<" . evil-shift-left)
("-" . evil-previous-line-first-non-blank))) ("-" . evil-previous-line-first-non-blank)))
(test-flan--check (format "under Evil, %s is still Evil's" (car k)) (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)))) (evil-mode -1))))
(message "\n%d checks, %d failures" test-flan--ran test-flan--failures) (message "\n%d checks, %d failures" test-flan--ran test-flan--failures)

103
emacs/test-flan-watch.el
View File

@ -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" (test-flan--check "and the last consumer out disarms the table"
(and (null flan-watch--consumers) torn)))) (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' ;; The daemon writes two kinds of frame: replies, and pushes it sends without
;; beside the read. A stopped program takes no samples, so there is no window ;; being asked — output as it is printed, the watch table while it is armed.
;; for a reset to close and none for it to open — and the runtime's lazy clear ;; The filter handles a push as it arrives and queues a reply for whoever is
;; is what keeps a paused program showing the numbers from the moment you ;; waiting. Frames are written into a pipe process's buffer by hand, split
;; paused it. So the tick must drop `:reset' while stopped and keep reading. ;; mid-frame the way a socket may deliver them, so what is claimed is the
;; ;; reader and not the daemon.
;; 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.
(defun test-flan-watch--tick-form (stopped) (defun test-flan-watch--frame (form)
"The form `flan-watch--tick' sends with the program STOPPED or not." "FORM framed as the daemon frames it."
(let ((sent nil) (let ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
(flan--stopped stopped) (format "%d\n%s" (length payload) payload)))
(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))))
(let ((running (test-flan-watch--tick-form nil)) (let* ((buf (generate-new-buffer " *flan-push-test*"))
(stopped (test-flan-watch--tick-form "BoundsError"))) (proc (make-pipe-process :name "flan-push-test" :buffer buf
(test-flan--check :noquery t))
"a tick while the program runs asks for the window it is closing" (painted nil)
(equal (nth 0 running) '(:op "watch" :reset t))) (appended nil)
(test-flan--check (flan-watch--consumers '(ghost)))
"a tick while the program is stopped sends no reset" (with-current-buffer buf (set-buffer-multibyte nil))
(null (plist-get (nth 0 stopped) :reset))) (unwind-protect
;; Skipping the tick outright would be worse than resetting: the watch would (cl-letf (((symbol-function 'flan-watch--absorb)
;; freeze at whatever it held when the program stopped, and a break loop is (lambda (r) (push r painted)))
;; exactly when the numbers are being read. ((symbol-function 'flan--append-output)
(test-flan--check (lambda (text) (push text appended))))
"but it still reads the table" (let ((flan-push-functions '(flan-watch--on-push))
(equal (plist-get (nth 0 stopped) :op) "watch")) (stream
(test-flan--check (concat
"and still has a reply in flight, so the cycle survives the pause" (test-flan-watch--frame '(:push "output" :status "ok"
(and (nth 1 running) (nth 1 stopped)))) :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) (provide 'test-flan-watch)
;;; test-flan-watch.el ends here ;;; test-flan-watch.el ends here

181
emacs/test-flan.el
View File

@ -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 ;; 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 ;; buffer — no REPL is open yet, and the log is the fallback that makes a
;; println never depend on one. ;; 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") (flan--eval "(defn step [] i64 (do (println \"HELLO\") ticks))" "form")
(let ((seen nil) (deadline (+ (float-time) 10))) (flan--stop-polling)
(while (and (not seen) (< (float-time) deadline)) (with-current-buffer (get-buffer-create flan-daemon-buffer)
(ignore-errors (flan--request '(:op "describe"))) (let ((inhibit-read-only t)) (erase-buffer)))
(setq seen (with-current-buffer (get-buffer-create flan-daemon-buffer) (let* ((pushes 0)
(string-match-p "HELLO" (buffer-string))))) (count (lambda (frame)
(test-flan--check "the program's output reaches the daemon's buffer" seen)) (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 ────────────────────────────────── ;; ── 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 ;; 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 ;; 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 ;; part that is only true in Emacs: the daemon sends the table on the same
;; an *asynchronous* sender and the ordinary synchronous request can share one ;; connection that carries replies, unasked, and neither gets in the way of
;; connection. ;; the other.
;; (let ((pushes 0))
;; The protocol is one reply per request on one socket. The watch timer (let ((count (lambda (_r) (setq pushes (1+ pushes)))))
;; sends and does not wait, deliberately, because waiting on a 0.2s timer (advice-add 'flan-watch--absorb :before count)
;; stalls the UI. That leaves a reply in flight that the next C-c C-c would (unwind-protect
;; read as its own — an evaluation reporting the watch table's answer, which (progn
;; is the exact bug `flan-settle-hook' exists to make impossible. This (flan-watch)
;; program writes nothing into the table, which does not matter: the (test-flan--check "the watch buffer opens" (get-buffer flan-watch-buffer))
;; interleaving is the claim. (test-flan--check "a program that watches nothing says so, rather than looking broken"
(flan-watch) (with-current-buffer flan-watch-buffer
(test-flan--check "the watch buffer opens" (get-buffer flan-watch-buffer)) (string-match-p "nothing is being watched" (buffer-string))))
(test-flan--check "and the timer is running" flan-watch--timer) ;; A body that writes the table, so there is something to send.
(test-flan--check "a program that watches nothing says so, rather than looking broken" (flan--eval "(defn step [] i64 (set ticks (+ ticks 1)) (watch \"ticks\" ticks) ticks)"
(with-current-buffer flan-watch-buffer "form")
(string-match-p "nothing is being watched" (buffer-string)))) (let ((until (+ (float-time) 5)))
;; The tick by hand, so this does not depend on a timer firing inside a batch (while (and (< (float-time) until)
;; run. Two of them: the first sends, the second collects and sends again. (not (with-current-buffer flan-watch-buffer
(flan-watch--tick) (string-match-p "^ticks" (buffer-string)))))
(test-flan--check "a tick leaves a request in flight rather than waiting for it" (accept-process-output flan--connection 0.05)))
flan-watch--pending) (test-flan--check "the table arrives without being asked for"
;; The background poll is a sender too, and it was the one sender that did (with-current-buffer flan-watch-buffer
;; not settle: it guarded on `flan--busy' alone, which the watch timer (string-match-p "^ticks [0-9]+" (buffer-string))))
;; deliberately does not bind — it never waits, so it has nothing to hold — ;; `ticks' moves every frame, so every push is a new table.
;; and sent `describe' straight into a connection that already owed a reply. (setq pushes 0)
;; It then read the watch's answer as its own, and the two stayed swapped (let ((until (+ (float-time) 1.0)))
;; for the rest of the session. The second check is where that would show: (while (< (float-time) until)
;; a `describe' answered by the watch table has no `:fns' in it at all. (accept-process-output flan--connection 0.02)))
(flan--poll) (test-flan--check
(test-flan--check "a poll settles the watch's reply rather than reading it as its own" (format "and keeps arriving at the repaint interval (%d in 1s)" pushes)
(null flan-watch--pending)) (<= 2 pushes 8)))
(test-flan--check "and the request after it is still answered by its own reply" (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")) (member "step" (plist-get (flan--request '(:op "describe"))
:fns))) :fns)))
;; And the same hook against a daemon restarted under an armed watch. The ;; A daemon restarted under an armed watch: the new connection arms it again.
;; 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)
(delete-process flan--connection) (delete-process flan--connection)
;; The timeout and the assertion are deliberately different numbers: what is (let ((r (flan--request '(:op "describe"))))
;; being told apart is a request that waited one out from a request that did (test-flan--check "after a reconnect the request is answered"
;; not, and the wider the gap the less this depends on how loaded the machine (member "step" (plist-get r :fns))))
;; running the suite happens to be. A reconnect and a `describe' are (with-current-buffer flan-watch-buffer
;; milliseconds of work. (let ((inhibit-read-only t)) (erase-buffer)))
(let ((flan-reply-timeout 10) (let ((until (+ (float-time) 5)))
(started (float-time))) (while (and (< (float-time) until)
(let ((r (flan--request '(:op "describe")))) (not (with-current-buffer flan-watch-buffer
(test-flan--check "a request after a restart does not wait out a reply the old connection owed" (string-match-p "^ticks" (buffer-string)))))
(and (member "step" (plist-get r :fns)) (accept-process-output flan--connection 0.05)))
(< (- (float-time) started) 3))) (test-flan--check "and the table is pushed again on the new connection"
(test-flan--check "and the watch is not left waiting for one either" (with-current-buffer flan-watch-buffer
(null flan-watch--pending)))) (string-match-p "^ticks" (buffer-string))))
;; 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.
;;
;; Back in the source buffer first: `flan-doc' and `flan-watch' above both ;; 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. ;; display buffers of their own, and C-c C-c reads the buffer it is run in.
(pop-to-buffer (flan--buffer-visiting file)) (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") (search-forward "(defn step")
(goto-char (match-beginning 0)) (goto-char (match-beginning 0))
(let ((said (test-flan--said (flan-eval-defun)))) (let ((said (test-flan--said (flan-eval-defun))))
(test-flan--check "an eval with a watch reply in flight still gets its own answer" (test-flan--check "an eval while the table is being pushed gets its own answer"
(and said (string-match-p "step" said))) (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)))
;; Point survives a repaint. This is why `replace-buffer-contents' is used ;; 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 ;; 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 ;; top of the buffer on every repaint, which makes the one thing you want to
;; in a watch buffer — look at a line while the program runs — impossible. ;; do in a watch buffer — look at a line while the program runs — impossible.
(with-current-buffer flan-watch-buffer (with-current-buffer flan-watch-buffer
(flan-watch--absorb '(:status "ok" :watch (("ticks" "1")) :overflow nil))
(goto-char (point-max)) (goto-char (point-max))
(let ((where (point))) (let ((where (point)))
(flan-watch--tick) (flan-watch--absorb '(:status "ok" :watch (("ticks" "2")) :overflow nil))
(flan-watch--tick)
(test-flan--check "and point does not jump to the top on a repaint" (test-flan--check "and point does not jump to the top on a repaint"
(= (point) where)))) (= (point) where))))
(flan-watch-stop) ;; Killing the buffer is how it is closed, and it disarms the table.
(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)))
(kill-buffer flan-watch-buffer) (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) (flan-disconnect)
(test-flan--check "disconnected" (not (process-live-p flan--connection))) (test-flan--check "disconnected" (not (process-live-p flan--connection)))

166
lib/dev.ml
View File

@ -4019,6 +4019,13 @@ let handle t req =
in in
disassemble t ~name ~form disassemble t ~name ~form
| None -> error "disassemble needs :name") | 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 "close" -> ok []
| Some op -> error ("unknown op: " ^ op) | Some op -> error ("unknown op: " ^ op)
| None -> error "no :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 ~loc:(Loc.to_string l) (message_of_exn e)
| _ -> error (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 ──────────────────────────────────────────────────────── *) (* ── The loop ──────────────────────────────────────────────────────── *)
(* One connection at a time. An editor is one client, evaluations are (* 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 so [close] shuts the whole thing down rather than waiting for another
connection nobody is going to make. *) connection nobody is going to make. *)
let serve t fd = 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 () = 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 match Wire.recv fd with
| src -> | src ->
(* One of the two places the agent clock is read — see [agent_check]. (* One of the two places the agent clock is read — see [agent_check].
@ -4125,6 +4288,9 @@ let serve t fd =
| r -> r | r -> r
| exception e when not (fatal e) -> reply_of_exn e) | exception e when not (fatal e) -> reply_of_exn e)
in 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 (* 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 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 and [with_output] drains its pipe, so they touch the same things the

23
test/test_dev.ml
View File

@ -4046,6 +4046,29 @@ let () =
| Some v -> v <> first | Some v -> v <> first
| None -> false)) | None -> false))
then fail "the watch table stopped moving"; 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 (* And off again. The value already in a slot stays — nothing clears
it — but the program stops writing, so it stops changing. *) it — but the program stops writing, so it stops changing. *)
if status (ask "(:op \"watch-enable\" :on nil)") <> "ok" then if status (ask "(:op \"watch-enable\" :on nil)") <> "ok" then