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

Program output reaches the editor as it is printed, and every Flan buffer keeps its keys under Evil

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 11:43:21 +07:00
commit a2eeb65f50
15 changed files with 907 additions and 404 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
TODO.org
View File

@ -2034,13 +2034,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.
@ -2097,11 +2099,14 @@ as code written in that file would, so =(integrate 1.0)= in =physics/step.flan=
reaches the package's own functions, =defn-= included. Today it answers reaches the package's own functions, =defn-= included. Today it answers
"unknown function", resolving as the program's main file. "unknown function", resolving as the program's main file.
** 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.

78
docs/BUILT.md
View File

@ -2383,8 +2383,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
@ -2437,6 +2437,56 @@ 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. **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
`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
``` ```
@ -6287,11 +6337,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
@ -6371,9 +6420,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
@ -6395,10 +6445,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.

18
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`.
@ -1203,6 +1206,7 @@ in the buffer).
| `flan-names-shown` | `4` | how many names to list before summarising | | `flan-names-shown` | `4` | how many names to list before summarising |
| `flan-poll-interval` | `1.0` | seconds between checks for whether it stopped | | `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-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-diagnostics-buffer` | `"*flan-diagnostics*"` | everything the compiler reports, kept |
| `flan-start-timeout` | `60` | seconds to wait for a program to come up | | `flan-start-timeout` | `60` | seconds to wait for a program to come up |
| `flan-lower-buffer` | `"*flan-lowering*"` | where `C-c C-l` writes | | `flan-lower-buffer` | `"*flan-lowering*"` | where `C-c C-l` writes |

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

@ -742,6 +742,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

@ -796,5 +796,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

3
emacs/flan-repl.el
View File

@ -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 ;; text — a plain marker does not advance — and the value the
;; reply carries would then land above the output it caused. ;; reply carries would then land above the output it caused.
(when (>= at (marker-position mark)) (when (>= at (marker-position mark))
(set-marker mark (point))))))))) (set-marker mark (point)))))
(flan--trim-lines)))))
(defun flan-repl--buffer () (defun flan-repl--buffer ()
"The REPL buffer, for the two clear commands, from wherever they are run." "The REPL buffer, for the two clear commands, from wherever they are run."

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, 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.
;;
;; 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

285
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
@ -353,6 +397,21 @@ Reconnecting happens before a send, never after one."
(bound-and-true-p flan-repl-buffer) (bound-and-true-p flan-repl-buffer)
(get-buffer 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) (defun flan--append-output (text)
"Append TEXT, the running program's own output, where it can be read. "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 Two places. The daemon's log always gets it, so output lands somewhere
@ -365,6 +424,7 @@ open, above its prompt, which is where whoever is typing there is looking."
(save-excursion (save-excursion
(goto-char (point-max)) (goto-char (point-max))
(insert text)) (insert text))
(flan--trim-lines)
;; Follow the tail only for someone who was already at it; a reader ;; Follow the tail only for someone who was already at it; a reader
;; scrolled back is reading something. ;; scrolled back is reading something.
(when at-end (goto-char (point-max))))) (when at-end (goto-char (point-max)))))
@ -496,24 +556,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 +564,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 +604,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 +644,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
@ -1495,11 +1551,17 @@ no longer wrong."
;; The bare keys grep-mode and compilation-mode readers reach for. The ;; 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 ;; 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. ;; major-mode half, possible because the buffer is read-only.
(define-key map (kbd "n") #'compilation-next-error) (define-key map (kbd "n") #'next-error-no-select)
(define-key map (kbd "p") #'compilation-previous-error) (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)
(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 +2282,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.")
@ -2888,6 +2960,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)

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

@ -210,54 +210,81 @@ 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)))
;; 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) (provide 'test-flan-watch)
;;; test-flan-watch.el ends here ;;; test-flan-watch.el ends here

188
emacs/test-flan.el
View File

@ -536,13 +536,56 @@ 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)))))
;; 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)))
(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.
(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 ──────────────────────────────────
;; ;;
@ -1335,68 +1378,56 @@ 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 — ;; And again, unasked, rather than once.
;; 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) 10)))
;; for the rest of the session. The second check is where that would show: (while (and (< pushes 2) (< (float-time) until))
;; a `describe' answered by the watch table has no `:fns' in it at all. (accept-process-output flan--connection 0.05)))
(flan--poll) (test-flan--check "and keeps arriving" (>= pushes 2)))
(test-flan--check "a poll settles the watch's reply rather than reading it as its own" (advice-remove 'flan-watch--absorb count))))
(null flan-watch--pending)) ;; Replies are not disturbed by the pushes around them.
(test-flan--check "and the request after it is still answered by its own reply" (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))
@ -1404,31 +1435,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)))

211
lib/dev.ml
View File

@ -68,6 +68,10 @@ type t = {
A signal here is a crash, and a crash keeps [dir] on disk: see A signal here is a crash, and a crash keeps [dir] on disk: see
[remove_session_dirs]. *) [remove_session_dirs]. *)
mutable died : Unix.process_status option; 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 (* 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 (* Bounded: a program that prints every frame must not grow this
process without limit. The newest text is the useful end. *) process without limit. The newest text is the useful end. *)
if Buffer.length t.out > capacity then begin 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 let keep = Buffer.sub t.out (Buffer.length t.out - capacity) capacity in
Buffer.clear t.out; Buffer.clear t.out;
Buffer.add_string t.out keep Buffer.add_string t.out keep
@ -112,7 +117,14 @@ let take t =
drain t; drain t;
let s = Buffer.contents t.out in let s = Buffer.contents t.out in
Buffer.clear t.out; 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 await ?(ms = 5000) f =
let rec go ms = let rec go ms =
@ -4196,6 +4208,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"
@ -4261,6 +4280,160 @@ 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.
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
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;
pend : Buffer.t; (* framed bytes not yet written *)
mutable sent : int; (* how many of [pend] have been *)
}
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))
let pending p = Buffer.length p.pend > p.sent
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
(* 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
(* 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. *)
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
@ -4271,7 +4444,34 @@ 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.; 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
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
(* 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
(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].
@ -4302,6 +4502,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
@ -4319,7 +4522,7 @@ let serve t fd =
here went straight past the two below and out of the accept loop, 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 ending the session. An editor that left before its reply arrived is a
closed connection and nothing more, which is what [false] says. *) 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 () | () -> if op = Some "close" then true else go ()
| exception Unix.Unix_error _ -> false) | exception Unix.Unix_error _ -> false)
| exception Wire.Closed -> false | exception Wire.Closed -> false
@ -4649,7 +4852,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
{ session; child = Some child; agent; dir; stdout = rd; { session; child = Some child; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false; agent_watch = None; host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false; died = None } park_noted = false; died = None; dropped = 0 }
in in
ignore_sigpipe (); ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ());
@ -5491,7 +5694,7 @@ let merged_setup () =
{ session; child = None; agent; dir; stdout = rd; { session; child = None; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false; agent_watch = None; host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false; died = None } park_noted = false; died = None; dropped = 0 }
in in
ignore_sigpipe (); ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ());

82
test/test_dev.ml
View File

@ -3925,6 +3925,65 @@ let () =
fail fail
"the evaluation drained the program's pipe and kept none of it, so \ "the evaluation drained the program's pipe and kept none of it, so \
the output it caused is gone"); 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\")"); ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ()); (try Unix.close c with Unix.Unix_error _ -> ());
if not if not
@ -4295,6 +4354,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