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

Merge master

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 12:54:55 +07:00
commit b74002be02
17 changed files with 1581 additions and 456 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
TODO.org
View File

@ -1080,6 +1080,10 @@ should not pay for identity and metadata. Not implemented.
function nosuch" twice at the same place and counts 2 errors — once from the
abstract pass and once from the instantiation.
** TODO A type variable is printed without its $
=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort
expects [t] here, found [3 i32]" where the source wrote =[$t]=.
** DONE Two refusals suggested something that does not compile
CLOSED: [2026-09-25]
=vec-new= and =map-new= with no type no longer say "or give the binding a type";
@ -1088,11 +1092,16 @@ An unknown call whose near miss is a value — =(context-allocator)= against
=context/allocator=, or a global — says the name is a value written without
parentheses, and names no call at all when the call had arguments.
** NEXT (max-of T) and (min-of T)
** NEXT (max-value T) and (min-value T)
Decided 2026-09-25: the type-limit constants as a form taking a type, Odin's
max(T), valid at any numeric type or a numeric?-bounded variable. For a float,
min-of is the most negative finite value.
** NEXT (Ptr const T), the pointer beside [const T]
Decided 2026-09-25: addr through a read-only slice gives a (Ptr const T), which
nothing writes through; (Ptr T) widens to it and never back; a C parameter
declared const T* takes one. Closes the addr hole in [const T].
* Backends
** DONE The x86 backend tracks LLVM at -O0
@ -1270,6 +1279,13 @@ lowering buffer annotates all four sections, the two =llc= ones from a =--debug=
copy of the IR. Rules out writing a disassembler, and reading the source off disk
at disassembly time.
** NEXT A temporary allocator, wiped each frame
Decided 2026-09-25: Odin's context.temp_allocator. i64->bytes, f64->bytes and
other quick formatting allocate from it, so a number drawn every frame no longer
leaks from the default allocator. A dev build wipes it at each frame boundary;
otherwise the program calls (free-temp) once per frame. Text kept past the frame
is cloned.
* Runtime
** DONE An index out of range is a condition
@ -1930,6 +1946,11 @@ C-x C-e thunk triggered. Needs reproducing under load and fixing.
* Editor
** TODO C-c C-l on a generic needs a session to find its copies
The lowering view compiles the file, but only the daemon's =defs= says which
functions are a generic's copies, so with no session a generic's name shows
nothing. Needs a way to ask the compiler for a file's copies of a name.
** DONE The syntax table and the font-lock lists are read off the parser
CLOSED: [2026-09-21]
The special-form list is the heads the parser dispatches on, the builtin list is
@ -2033,13 +2054,15 @@ Open: what migration does with a stored value that no longer fits a changed
slot type, and whether an untyped slot stays legal (it should — =dyn= is a type
and writing nothing should mean it).
** NEXT println takes up to a second to appear
Decided 2026-09-25: the daemon pushes program output on the editor's connection as it is written. Rules out a faster poll.
Output is drained by =flan--poll= at =flan-poll-interval=, 1.0s
(=emacs/flan.el:541=). A reply carries whatever was buffered when it was
composed, so anything the program prints after that waits for the next tick.
Polling faster costs a request a second for nothing most of the time; the
daemon pushing on its own connection is the other shape. Decide which.
** DONE println takes up to a second to appear
CLOSED: [2026-09-25]
The daemon pushes program output on a connection that asked for pushes
(=(:op "push" :on t)=), coalesced to at most one frame per 50ms, and the
watch table on the same channel at =flan-watch-interval=. Emacs reads every
frame in a process filter. The editor's watch timer and =flan-settle-hook=
are gone. The poll stays for the stop and park edges. Rules out a faster
poll and pushes to clients that did not ask for them. See docs/BUILT.md,
"Output and the watch table are pushed".
** NEXT set writes a class slot; put is for maps
Decided 2026-09-25: as written; one lane with typed slots.
@ -2090,11 +2113,14 @@ motion states in that mode; every other key, including what =special-mode-map=
binds, stays Evil's. The other special-mode buffers (inspect, watch, doc, disassembly,
diagnostics, lower) have the same exposure and are not changed.
** NEXT Evil takes the keys in the other Flan buffers
The inspect, watch, doc, disassembly, diagnostics and lower buffers get the break
buffer's treatment: the keys each binds itself go to Evil's normal and motion
states, and every other key stays Evil's. Bindings stay as close as possible
between Evil and Emacs states.
** DONE Evil takes the keys in the other Flan buffers
CLOSED: [2026-09-25]
=flan-evil-own-keys= (flan-mode.el) gives the keys a mode's own map binds to
Evil's normal and motion states; the break, inspect, watch, doc, disassembly,
diagnostics and lower buffers all call it. The doc, disassembly and watch
maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are
the mode's own and behave the same under Evil. Every key a mode does not bind
itself, including the rest of =special-mode-map=, stays Evil's.
** NEXT Eval in the frame, from the break loop
Decided 2026-09-25: SLIME's eval-in-frame, as described.

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
errors — and that is a reply the client is already reading. Finding out a second later from a poll would mean finding
out *after* the echo area had said the evaluation was fine.
- **And a timer asks anyway**, once a second, with `describe` — the cheap op, which is also how the output pipe is
drained. A program that stops in a frame of its own game loop produces no reply at all, and folding state into replies
- **And a timer asks anyway**, once a second, with `describe` — the cheap op. (It used to be how the program's output
reached the editor as well; output is pushed now, below.) A program that stops in a frame of its own game loop produces no reply at all, and folding state into replies
that never come says nothing. The timer never *reconnects*: `flan--request` reopens a socket a restarted daemon left
behind, which is right for something a person did and wrong for a background poll, because it would quietly erase the
`lost` state that exists to be seen. It also skips while another request is in flight — `accept-process-output` runs
@ -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`
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
```
@ -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.
**One reply, two pictures.** Ghost text does not poll. It is painted from `flan-watch--absorb`, the same function
that paints the buffer, from the same reply, so the two cannot disagree and there is no second `:op "watch"` in
flight — the one-request invariant `flan-settle-hook` exists to keep. What had to change is that the **watch
buffer used to be the subscription**: killing it cancelled the timer and disarmed the table. That was right while it
was the only consumer and wrong the moment it was not, so arming and the timer now hang off
`flan-watch--consumers`, and only the last consumer out turns the lights off.
that paints the buffer, from the same push, so the two cannot disagree. What had to change is that the **watch
buffer used to be the subscription**: killing it disarmed the table. That was right while it was the only consumer and
wrong the moment it was not, so arming hangs off `flan-watch--consumers`, and only the last consumer out turns the
lights off.
**Overlays are replaced wholesale on every repaint**, never followed through edits. That is the entire answer to the
invalidation problem the earlier note called the work: a line that moved cannot strand an overlay, because no overlay
@ -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
`max` over a whole session reach the session's extremes within a few seconds of play and then never move again, so
the two most useful of the five go dead exactly when you start interacting with the thing you are debugging. This
tool exists to show you a number while you drag the mouse. So `flan-watch--tick` sends `:reset t` beside its read and
the displayed range is "since you last looked" — a fifth of a second, a dozen frames. A caller that wants the
cumulative numbers gets them by not resetting; the setting lives in the editor, not in the runtime.
tool exists to show you a number while you drag the mouse. So each push of the table resets after its read and the
displayed range is "since you last looked" — a fifth of a second, a dozen frames. A caller of the `watch` op that
wants the cumulative numbers gets them by not passing `:reset t`; the policy lives in the daemon's push, not in the
runtime.
**Reset is its own message, and it is not a side effect of reading.** A destructive read was the tempting shape and
is wrong: it makes *looking* change what is there, so anything that polls — a test's `await`, a second editor, a
@ -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
watch for as long as the program sat in a break loop, and reading the numbers from the moment you stopped is the
entire point of stopping. The lazy clear gives exactly the right answer there. What was actually wrong was narrower
and lives in the editor: `flan-watch--tick` was sending `:reset t` five times a second at a program that could not
answer it. So the reset is now guarded on `flan--stopped` — the read still goes out every tick, only the reset
field drops — and the runtime is untouched. That keeps the policy where the rest of this section already put it:
"since you last looked" is the editor's idea, not the table's. `watch_render_num`'s unreachable `n=0` arm is deleted
and was a reset sent five times a second at a program that could not answer it. So the reset is guarded on the
program being stopped — the table is still read and pushed, only the reset is skipped — and the runtime is untouched.
The guard was the editor's while the editor polled the table; it is `push_due`'s in `dev.ml` now that the daemon
pushes it, asked of the program with `status` at each push. `watch_render_num`'s unreachable `n=0` arm is deleted
rather than commented, since the only way to reach it is the epoch check that was just rejected, and dead code is an
invitation to add one.

18
emacs/MANUAL.md
View File

@ -316,8 +316,10 @@ that is what the program calls it.
form rides along on the reply and is inserted above the prompt — output
first, then the value, the way a terminal REPL reads. When a compile fails
the prompt gets one line, `1 error — see *flan-diagnostics*`, and the message
itself is in that buffer, which pops up. The daemon's buffer `*flan*` mirrors
all program output, so a println is never lost when no prompt is open.
itself is in that buffer, which pops up. What the program prints on its own,
between evaluations, is sent by the daemon as it is printed and appears at
once. The daemon's buffer `*flan*` mirrors all program output, so a println is
never lost when no prompt is open.
**Two clears.** `C-c C-o` removes what the last send produced — output, value
or error line — and leaves the transcript. `C-c M-o` erases the transcript
@ -769,9 +771,9 @@ The slot renders as `n=… min=… max=… last=… mean=…`, one line per
Two entry points rather than one so a program need not cast at the call site.
The write path does **no formatting** — a sample is a load, five compares and
the slot's seqlock — and the listener thread renders once per editor tick, which
the slot's seqlock — and the listener thread renders once per repaint, which
is the whole reason this exists rather than a second `watch-i64`. **The window is
since the editor's last tick**, not since the program started: a min and a max
since the last repaint**, not since the program started: a min and a max
over a whole session reach the session's extremes within seconds and then never
move again, so the two most useful of the five would go dead exactly when you
start playing. A whole number prints as one, because a spy on an array index
@ -817,11 +819,12 @@ your own entry points to names that do not start with `watch`, set
`flan-watch-ghost-call-regexp` — the Flan name is yours, and only the C symbol
behind it is fixed.
**When it updates.** On the same timer as the buffer, from the same reply, so
the two cannot disagree. As with the buffer, the interval decides how often the
**When it updates.** Each time the daemon sends the table, from the same frame
as the buffer, so the two cannot disagree. As with the buffer, the interval decides how often the
picture is repainted and not how fresh it is. Overlays are replaced wholesale
each repaint rather than followed through your edits, so a line you moved never
leaves one stranded, and a file you scroll to gets its values within a tick.
leaves one stranded, and a file you scroll to gets its values at the next
repaint.
Only buffers **shown in a window** are scanned, which is what keeps that cheap.
**One name, two call sites.** Both show it, and both say `one slot, 2 sites`.
@ -1229,6 +1232,7 @@ in the buffer).
| `flan-names-shown` | `4` | how many names to list before summarising |
| `flan-poll-interval` | `1.0` | seconds between checks for whether it stopped |
| `flan-daemon-buffer` | `"*flan*"` | the daemon's own log; mirrors program output |
| `flan-output-maximum-lines` | `5000` | lines `*flan*` and the REPL keep; older ones are deleted |
| `flan-diagnostics-buffer` | `"*flan-diagnostics*"` | everything the compiler reports, kept |
| `flan-start-timeout` | `60` | seconds to wait for a program to come up |
| `flan-lower-buffer` | `"*flan-lowering*"` | where `C-c C-l` writes |

20
emacs/flan-cnr.el
View File

@ -64,6 +64,7 @@
(require 'seq)
(require 'subr-x)
(require 'flan-mode)
(declare-function flan--request "flan" (form))
(declare-function flan-visit-loc "flan" (loc subject))
@ -832,22 +833,9 @@ anyone who would rather TAB always moved."
"Keys in `flan-cnr-mode'.")
;; Evil's normal state binds 0, the other digits and RET above any major
;; mode's map, so under Evil a digit moved point or started a count and took
;; nothing. The keys this file binds are given to Evil's normal and motion
;; states in this mode. Only those keys: `flan-cnr-mode-map' inherits
;; `special-mode-map', and making it an overriding map would carry h, SPC, <
;; and - over from there as well. Every key not listed stays Evil's.
(with-eval-after-load 'evil
(when (fboundp 'evil-define-key*)
;; Collected first, and without the parent's bindings, because
;; `evil-define-key*' writes into the map being walked.
(let ((own nil))
(map-keymap-internal (lambda (key def)
(when (commandp def) (push (cons key def) own)))
flan-cnr-mode-map)
(dolist (b own)
(evil-define-key* '(normal motion) flan-cnr-mode-map
(vector (car b)) (cdr b))))))
;; mode's map, so under Evil a digit would move point or start a count and
;; take nothing. See `flan-evil-own-keys'.
(flan-evil-own-keys 'flan-cnr-mode-map)
(define-derived-mode flan-cnr-mode special-mode "flan-break"
"What a stopped Flan program is offering."

3
emacs/flan-inspect.el
View File

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

37
emacs/flan-lower.el
View File

@ -415,6 +415,40 @@ looks like."
(buffer-substring-no-properties beg (line-beginning-position 2))
(buffer-substring-no-properties beg (point-max)))))))
(defun flan-lower--copies (name)
"The names of the copies of generic NAME the connected program has, or nil.
A generic has no code under its own name: each type it is called at makes a
copy named for the types, `selection-sort-i32'. The daemon lists the generic
with its signature as written, `$' and all, and lists each copy with the
generic's own location -- which is what tells a copy from an unrelated
function that happens to share the prefix, `sort-bytes' beside `sort'."
(let ((g (assoc name flan--defs)))
(when (and g (string-match-p "\\$" (nth 2 g)))
(let ((prefix (concat name "-")))
(sort (mapcar #'car
(seq-filter
(lambda (d)
(and (string-prefix-p prefix (car d))
(equal (nth 1 d) "fn")
(equal (nth 3 d) (nth 3 g))))
flan--defs))
#'string<)))))
(defun flan-lower--fetch-copies (section name)
"SECTION for each copy of generic NAME, each under a line naming it, or nil.
The copies are the session's, and the file may call the generic at fewer
types than the session does; a copy the file does not make is named as such
rather than left out."
(let ((copies (flan-lower--copies name)))
(and copies
(mapconcat
(lambda (c)
(format ";; %s\n%s" c
(or (funcall flan-lower-fetch-function
section flan-lower--file c flan-lower--flags)
"not made by this file: nothing in it calls at these types\n")))
copies "\n"))))
(defun flan-lower--gather (sections)
"Fetch each of SECTIONS into `flan-lower--texts', replacing what was there.
One section's failure is that section's text and not the buffer's: `llc' can
@ -425,6 +459,7 @@ altogether would be the wrong answer to that."
(or (funcall flan-lower-fetch-function
s flan-lower--file flan-lower--name
flan-lower--flags)
(flan-lower--fetch-copies s flan-lower--name)
(format "nothing for `%s' here\n" flan-lower--name))
(error (concat (error-message-string err) "\n")))))
(setf (alist-get s flan-lower--texts) text))))
@ -742,6 +777,8 @@ that is felt."
map)
"Keys in `flan-lower-mode'.")
(flan-evil-own-keys 'flan-lower-mode-map)
(define-derived-mode flan-lower-mode special-mode "flan-lower"
"Every lowering of one Flan function, in foldable sections.

33
emacs/flan-mode.el
View File

@ -796,5 +796,38 @@ decision to `calculate-lisp-indent'."
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode))
;;; The other Flan buffers under Evil
;; Evil's normal state binds most single keys — the digits, RET, TAB, n, p, q,
;; g — above any major mode's map, so in a buffer of Flan's own a key its mode
;; binds would move point, start a count or record a macro instead. Each such
;; buffer's mode gives the keys its own map binds to Evil's normal and motion
;; states, so they do the same thing under Evil as without it. Only those
;; keys: the maps inherit `special-mode-map', and making one an overriding map
;; would carry h, SPC, < and - over from there as well. Every key a mode does
;; not bind itself stays Evil's.
(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings))
(defun flan-evil-own-keys (name)
"Give the keys the map named NAME binds itself to Evil's states.
Normal and motion. Takes effect when Evil is loaded, or at once if it
already is.
The map is passed by name because `eval-after-load' drops a function
`equal' to one it already holds, and two maps with the same bindings are
`equal': given the maps, only the first of them would be set up."
(with-eval-after-load 'evil
(when (fboundp 'evil-define-key*)
;; Collected first, and without the parent's bindings, because
;; `evil-define-key*' writes into the map being walked.
(let ((map (symbol-value name))
(own nil))
(map-keymap-internal (lambda (key def)
(when (commandp def) (push (cons key def) own)))
map)
(dolist (b own)
(evil-define-key* '(normal motion) map (vector (car b)) (cdr b)))))))
(provide 'flan-mode)
;;; flan-mode.el ends here

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

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
;; could not have given:
;;
;; the values update at *frame rate* rather than at the timer's rate — the
;; timer only decides how often the picture is repainted, not how fresh it
;; is;
;; the values update at *frame rate* rather than at the repaint rate — the
;; interval only decides how often the picture is repainted, not how fresh
;; it is;
;;
;; and the last frame's values are still there while the program is
;; *stopped*. A break loop is precisely when no thunk can run at a frame
;; boundary, because there are no more frames, and precisely when you want to
;; see what the last one held.
;;
;; Also kept from the original, and for its stated reasons: the request is
;; **async**, because a synchronous call on a timer blocks Emacs's UI every
;; tick; and the paint is `replace-buffer-contents' rather than erase-and-
;; insert, because it diffs, so point and scroll survive a repaint instead of
;; being yanked to the top five times a second.
;; The daemon reads the table and sends it on the editor's connection, as it
;; sends the program's output, so Emacs never waits on a timer for it. The
;; paint is `replace-buffer-contents' rather than erase-and-insert, because it
;; diffs, so point and scroll survive a repaint instead of being yanked to the
;; top five times a second.
;;
;; What a program writes:
;;
@ -92,19 +92,17 @@
"Seconds between repaints.
This is the *repaint* rate, not the watch rate. The program writes its values
every frame whatever this is; all this decides is how often the picture is
refreshed, which is why a slow value here costs freshness and nothing else."
every frame whatever this is; all this decides is how often the daemon sends
the table, which is why a slow value here costs freshness and nothing else.
Taken when the table is armed, so a change applies from the next `flan-watch'."
:type 'number)
(defvar flan-watch--timer nil)
(defvar flan-watch--pending nil
"Non-nil while a watch request is out and its reply has not been read.")
(defvar flan-watch--rows nil
"The last table painted, as a list of (NAME . VALUE).")
(defvar flan-watch--consumers nil
"Which pictures of the table are currently wanted: `buffer', `ghost', or both.
There is one table, one arming message and one timer, and more than one way to
There is one table, one arming message and one push, and more than one way to
look at what they produce. Holding the subscription here rather than in the
watch buffer is what lets ghost text outlive that buffer being closed — the
original design made the buffer *be* the subscription, which was right when it
@ -183,12 +181,11 @@ was the only consumer and wrong the moment it was not.")
;; the string literal and not the head is what makes that safe: a name in the
;; table came from one of these call sites by construction.
;;
;; WHEN IT UPDATES. On the same timer, from the same reply. The two pictures
;; therefore cannot disagree — they are one table read, painted twice — and
;; there is no second `:op "watch"' in flight, which is the invariant
;; `flan-settle-hook' exists to keep. As with the buffer, the timer decides
;; how often the picture is repainted and not how fresh it is: the program
;; writes every frame regardless.
;; WHEN IT UPDATES. On the same push, from the same frame. The two pictures
;; therefore cannot disagree — they are one table read, painted twice. As
;; with the buffer, the push interval decides how often the picture is
;; repainted and not how fresh it is: the program writes every frame
;; regardless.
;;
;; Overlays are deleted and re-placed from scratch on every repaint rather than
;; being tracked across edits. That is the whole answer to the invalidation
@ -335,10 +332,10 @@ Guarded on the row's length so a short name cannot be claimed by accident."
(overlay-put ov 'flan-watch-ghost t)
(push ov flan-watch--ghost-overlays))))))))))
;;; The tick
;;; The push
(defun flan-watch--absorb (reply)
"Paint REPLY, a watch answer from the daemon."
"Paint REPLY, a watch table from the daemon."
(pcase (plist-get reply :status)
("ok"
(setq flan-watch--rows
@ -357,94 +354,72 @@ Guarded on the row's length so a short name cannot be claimed by accident."
(flan-watch--paint
(format "error:\n%s\n" (or (plist-get reply :message) "refused"))))))
(defun flan-watch--settle ()
"Collect an outstanding watch reply, blocking if it has not arrived.
;; The daemon sends the table on the connection every `flan-watch-interval'
;; while it is armed, 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
timer's reply as its own. Blocking here is fine and blocking in the tick is
not: this runs inside something a person asked for, which already waits, and
what it waits for is a table read with nothing compiled behind it."
(when flan-watch--pending
(setq flan-watch--pending nil)
(when-let* ((proc flan--connection))
(when (process-live-p proc)
(ignore-errors (flan-watch--absorb (flan--read-reply proc)))))))
(defun flan-watch--on-push (kind frame)
"Paint FRAME when KIND says it is the watch table."
(when (and (equal kind "watch") flan-watch--consumers)
(flan-watch--absorb frame)))
(defun flan-watch--tick ()
"Collect the last reply if it has come, then ask again. Never blocks.
(defun flan-watch--on-connect ()
"Arm the table again on a new connection, if anything is watching.
A restarted daemon has a new program, and the new program's table is off."
(when flan-watch--consumers
(let ((r (ignore-errors (flan-watch--arm t))))
(unless (equal (plist-get r :status) "ok")
(flan-watch--paint
(format "error:\n%s\n"
(or (plist-get r :message) "the table could not be armed")))))))
Deliberately not `flan--request', which waits for its answer: a
synchronous call on a 0.2s timer stalls Emacs's UI every tick, and a timer is
the one caller that must not. So this takes whatever has already arrived and
sends the next question, leaving at most one request in flight — the invariant
`flan-settle-hook' exists to keep."
(cond
;; Killing the buffer cancels the buffer's half of the subscription, and
;; only that. When it was the only consumer this stops the timer and
;; disarms the table, so a program nobody is watching is back to paying a
;; load and a branch per watch call; when ghost text is also on, the table
;; stays armed and the ticks carry on feeding it.
((and (memq 'buffer flan-watch--consumers)
(not (get-buffer flan-watch-buffer)))
(flan-watch--drop 'buffer))
((not (process-live-p flan--connection))
(flan-watch--paint "error:\nnot connected to a running program\n")
(flan-watch-stop))
;; Something else owns the connection this instant — an evaluation is
;; mid-flight. Skipping is right: its `flan-settle-hook' has already
;; taken any reply of ours, and the next tick is 0.2s away.
(flan--busy nil)
(t
(when flan-watch--pending
;; Taken off the connection either way. `flan--extract-reply'
;; deletes a frame before it reads it, so a payload that will not read
;; has still been consumed — and a pending flag left standing after it
;; would wait for ever for a reply that is no longer in the buffer,
;; which stops the timer sending anything again. One bad reply costs
;; one tick, not the session.
(when-let* ((reply (condition-case nil
(flan--take-reply flan--connection)
(error (setq flan-watch--pending nil) nil))))
(setq flan-watch--pending nil)
(flan-watch--absorb reply)))
(unless flan-watch--pending
(condition-case nil
;; `:reset t' opens a new accumulation window for the numeric
;; slots, so their count, range and mean are "since the last tick"
;; rather than since the program started. That is the whole of the
;; accumulator decision as the editor sees it: a min and a max over
;; a session go dead within seconds of play, and this tool exists to
;; show a number while you drag the mouse. The reset happens after
;; the read, on the daemon's side, so this tick's numbers are the
;; last tick's window and nothing is lost between the two.
;;
;; Except while the program is stopped, when the read still happens
;; and the reset does not. A stopped program takes no samples, so
;; there is no window for a reset to close and none for it to open:
;; the runtime clears a slot lazily, on its next sample, which is
;; what keeps a paused program showing the numbers from the moment
;; you paused it — the whole reason to pause. Resetting anyway
;; would ask for a new window five times a second that nothing can
;; fill. The guard lives here rather than in the runtime because
;; "since you last looked" is the editor's policy, not the table's.
;; `flan--stopped' is the one place that state is tracked, and
;; `flan.el''s background poll keeps it current whether or not
;; anyone is evaluating.
(progn (flan--send flan--connection
(if flan--stopped
'(:op "watch")
'(:op "watch" :reset t)))
(setq flan-watch--pending t))
(error (flan-watch-stop)))))))
(defun flan-watch--on-disconnect ()
"Say that the table is no longer live."
(when flan-watch--consumers
(flan-watch--ghost-clear)
(flan-watch--paint "error:\nnot connected to a running program\n")))
(defun flan-watch--arm (on)
"Ask the daemon to arm the table and push it, or to disarm it when ON is nil."
(flan--request (if on
`(:op "watch-enable" :on t :interval ,flan-watch-interval)
'(:op "watch-enable" :on nil))))
;;; Commands
(defvar flan-watch-mode-map
(let ((map (make-sparse-keymap)))
;; As `flan-doc-mode-map'.
(define-key map "q" #'quit-window)
map)
"Keys in `flan-watch-mode'.")
(flan-evil-own-keys 'flan-watch-mode-map)
(define-derived-mode flan-watch-mode special-mode "flan-watch"
"Major mode for the pinned watch buffer."
(setq-local truncate-lines t))
(setq-local truncate-lines t)
;; Killing the buffer cancels the buffer's half of the subscription, and only
;; that. When it was the only consumer the table is disarmed, so a program
;; nobody is watching is back to paying a load and a branch per watch call;
;; when ghost text is also on, the table stays armed.
(add-hook 'kill-buffer-hook #'flan-watch--buffer-killed nil t))
(defun flan-watch--buffer-killed ()
"Drop the buffer consumer, the watch buffer being killed."
(when (memq 'buffer flan-watch--consumers)
(flan-watch--drop 'buffer)))
(defun flan-watch--subscribe (consumer)
"Arm the table for CONSUMER and make sure the shared timer is running.
"Arm the table for CONSUMER.
Arming is a message, not something the daemon infers. The program is the
writer, so it has to be told somebody is looking — and while nobody is, nothing
@ -453,15 +428,14 @@ debugging a load and a not-taken branch. It is sent once for the first
consumer: two of them looking at one table is still one table."
(flan--live-connection)
(unless flan-watch--consumers
(let ((r (flan--request '(:op "watch-enable" :on t))))
(let ((r (flan-watch--arm t)))
(unless (equal (plist-get r :status) "ok")
(user-error "flan: %s" (or (plist-get r :message) "watch refused")))))
(unless (memq consumer flan-watch--consumers)
(push consumer flan-watch--consumers))
(add-hook 'flan-settle-hook #'flan-watch--settle)
(when flan-watch--timer (cancel-timer flan-watch--timer))
(setq flan-watch--timer
(run-with-timer 0 flan-watch-interval #'flan-watch--tick)))
(add-hook 'flan-push-functions #'flan-watch--on-push)
(add-hook 'flan-connected-hook #'flan-watch--on-connect)
(add-hook 'flan-disconnected-hook #'flan-watch--on-disconnect))
(defun flan-watch--drop (consumer)
"Stop painting CONSUMER, and tear everything down if it was the last one."
@ -476,7 +450,7 @@ consumer: two of them looking at one table is still one table."
(flan-watch--subscribe 'buffer)
(with-current-buffer (get-buffer-create flan-watch-buffer)
(unless (eq major-mode 'flan-watch-mode) (flan-watch-mode)))
;; Painted before the first reply, rather than left blank until one arrives.
;; Painted before the first push, rather than left blank until one arrives.
;; An empty buffer is the same picture as a broken one, and the likeliest
;; reason for it here is the honest one — the program is not calling into the
;; table — which is worth saying in words rather than by showing nothing.
@ -510,21 +484,15 @@ Tears down both consumers. `flan-watch--drop' is the way to stop one of them."
;; `flan-watch--drop' and back into here.
(setq flan-watch-ghost-mode nil)
(flan-watch--ghost-clear)
(when flan-watch--timer
(cancel-timer flan-watch--timer)
(setq flan-watch--timer nil))
;; Settle before disarming, or the disarm request reads the tick's reply.
(flan-watch--settle)
(remove-hook 'flan-settle-hook #'flan-watch--settle)
;; Only on a connection that is already live, and this is the important half.
;; `flan--request' *reconnects* — which is right for something a person
;; did and wrong here, because this is also called from the tick, and the
;; reason the tick calls it is that the connection has gone. Reconnecting
;; from a timer would quietly erase the `lost' state that exists to be seen,
;; which `flan.el' already forbids for its own poll timer. And there is
;; nothing to disarm anyway: the table went with the program.
(remove-hook 'flan-push-functions #'flan-watch--on-push)
(remove-hook 'flan-connected-hook #'flan-watch--on-connect)
(remove-hook 'flan-disconnected-hook #'flan-watch--on-disconnect)
;; Only on a connection that is already live. `flan--request' reconnects,
;; which is right for something a person did and wrong here: there is
;; nothing to disarm when the connection has gone, because the table went
;; with the program.
(when (process-live-p flan--connection)
(ignore-errors (flan--request '(:op "watch-enable" :on nil)))))
(ignore-errors (flan-watch--arm nil))))
;;; What ghost text still cannot show

375
emacs/flan.el
View File

@ -244,44 +244,96 @@ to."
'utf-8 t)))
(process-send-string proc (format "%d\n%s" (length payload) payload))))
(defun flan--take-reply (proc)
"Read one complete framed message out of PROC's buffer, or return nil.
;; Two kinds of frame arrive on the connection. A reply answers the request
;; that is waiting for it. A push is sent without being asked for — the
;; program's output as it is printed, and the watch table while one is armed —
;; and is marked `:push' with its kind. The daemon sends pushes only to a
;; connection that asked for them (`flan--open' does), and never in the middle
;; of a reply.
;;
;; The process filter takes every complete frame off the head of the buffer as
;; it arrives: a push is handled there and then, which is what puts a
;; `println' on the screen as it happens, and a reply is queued on the process
;; for `flan--read-reply' to collect. The reader runs the same collection
;; itself before it looks, so frames that reached the buffer by some other way
;; than the filter are read the same.
Never waits. This is the half of `flan--read-reply' that does not block,
split out for the watch timer: a timer that called `accept-process-output'
would stall the UI every tick, which is exactly the mistake the Clojure
original left a comment about. See `flan-watch--tick'."
(defvar flan-push-functions nil
"Functions called with each push from the daemon other than output.
Each is called with two arguments, the kind as a string (\"watch\") and the
frame as a plist. Output is handled by `flan--append-output' directly.")
(defun flan--dispatch-push (frame)
"Handle FRAME, a push from the daemon.
Errors are reported and go no further: this runs inside a process filter,
where an error would stop the frames behind it from being read."
(with-demoted-errors "flan: a push from the daemon failed: %S"
(let ((kind (plist-get frame :push)))
(if (equal kind "output")
(flan--append-output (plist-get frame :output))
(run-hook-with-args 'flan-push-functions kind frame)))))
(defun flan--collect (proc)
"Take every complete frame off the head of PROC's buffer.
A push is dispatched; a reply is queued for `flan--take-reply'. A reply that
will not read is queued as its error, so the request that asked for it is the
one that signals."
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
(when (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
(let* ((n (string-to-number (match-string 1)))
(body-start (point)))
;; Present in full, or not yet — a partial body is not an error here,
;; it is the ordinary state between the send and the reply.
(when (>= (- (position-bytes (point-max)) (position-bytes body-start)) n)
(flan--extract-reply body-start n)))))))
(let (frame)
(while (setq frame (progn (goto-char (point-min))
(flan--next-frame)))
(let ((text (car frame)))
(if (string-prefix-p "(:push " text)
(condition-case nil
(flan--dispatch-push (car (read-from-string text)))
;; An unreadable push is a daemon bug, and it answers
;; nobody's request, so nothing is queued for it.
(error (message "flan: an unreadable push from the daemon was dropped")))
(process-put proc 'flan-replies
(append (process-get proc 'flan-replies)
(list (condition-case err
(cons 'ok (car (read-from-string text)))
(error (cons 'bad err)))))))))))))
(defun flan--extract-reply (body-start n)
"Read the N bytes at BODY-START as a reply and delete the frame.
Point is in the process buffer, and the frame is known to be complete.
(defun flan--next-frame ()
"Remove the complete frame at point-min and return (TEXT), or return nil.
Point is in a process buffer. The frame is deleted before anything reads it,
so a payload that will not read is consumed once rather than read again by
every request after it."
(when (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
(let* ((n (string-to-number (match-string 1)))
(body-start (point)))
;; Present in full, or not yet — a partial body is the ordinary state
;; between the first packet of a frame and its last.
(when (>= (- (position-bytes (point-max)) (position-bytes body-start)) n)
(let* ((end (byte-to-position (+ (position-bytes body-start) n)))
(text (decode-coding-string
(encode-coding-string (buffer-substring-no-properties
body-start end)
'utf-8 t)
'utf-8)))
(delete-region (point-min) end)
(list text))))))
The frame is deleted *before* it is read, which is the whole of the ordering
and the only reason this is worth a comment. A payload that will not read is
a bug at the other end, and the client's job is to report it once: reading
first would leave those bytes at the head of the buffer, so the next request
would read the same unreadable frame again, and every request after that —
one bad reply and the connection is wedged until Emacs is restarted.
Consuming it first costs the reply, which was lost anyway, and leaves the
stream in step for the request that follows."
(let* ((end (byte-to-position (+ (position-bytes body-start) n)))
(text (decode-coding-string
(encode-coding-string (buffer-substring-no-properties
body-start end)
'utf-8 t)
'utf-8)))
(delete-region (point-min) end)
(car (read-from-string text))))
(defun flan--filter (proc string)
"Append STRING to PROC's buffer and take off whatever frames are complete."
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(goto-char (point-max))
(insert string))
(flan--collect proc)))
(defun flan--take-reply (proc)
"The next reply PROC has sent, or nil if none has arrived. Never waits.
A reply that would not read signals here, having already been consumed."
(flan--collect proc)
(let ((q (process-get proc 'flan-replies)))
(when q
(process-put proc 'flan-replies (cdr q))
(pcase (car q)
(`(ok . ,reply) reply)
(`(bad . ,err) (signal (car err) (cdr err)))))))
(defun flan--no-reply (proc)
"Signal that PROC has not answered, saying which of the two silences it is.
@ -306,41 +358,33 @@ Reconnecting happens before a send, never after one."
(abbreviate-file-name (or flan--socket "?")))))
(defun flan--read-reply (proc)
"Block until PROC sends one complete framed message, and read it."
(with-current-buffer (process-buffer proc)
(let ((deadline (+ (float-time) flan-reply-timeout)))
;; The header first: digits up to a newline.
(while (and (not (save-excursion (goto-char (point-min))
(re-search-forward "\\`\\([0-9]+\\)\n" nil t)))
(< (float-time) deadline))
(accept-process-output proc 0.05))
(goto-char (point-min))
;; Nothing is erased here, and that is the difference between the two
;; deadlines. A header that has not arrived in full is a valid prefix
;; of a reply still on its way — throwing it away would turn a daemon
;; that is merely slow into a stream out of step by however much of the
;; count had landed.
(unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
(flan--no-reply proc))
(let* ((n (string-to-number (match-string 1)))
(body-start (point)))
(while (and (< (- (position-bytes (point-max)) (position-bytes body-start)) n)
(< (float-time) deadline))
(accept-process-output proc 0.05))
(if (>= (- (position-bytes (point-max)) (position-bytes body-start)) n)
(flan--extract-reply body-start n)
;; The body never came, so the count at the head of the buffer is a
;; promise about bytes that will never be made good: reading on from
;; here would take the *next* reply's header as this one's payload
;; and every request after it would be answered by the one before.
;; The frame is dead — drop it, and the connection is in step again
;; for whatever a person does next. Testing the condition again
;; rather than trusting the loop is the whole fix: falling through
;; to `flan--extract-reply' with a short buffer signals a
;; wrong-type error from `byte-to-position', which says nothing
;; about a timeout to whoever reads it.
(erase-buffer)
(flan--no-reply proc))))))
"Block until PROC sends a reply, and return it.
Pushes that arrive first are handled as they come."
(let ((deadline (+ (float-time) flan-reply-timeout))
(got nil) (reply nil))
(while (and (not got) (< (float-time) deadline))
(if (process-get proc 'flan-replies)
(setq reply (flan--take-reply proc) got t)
(flan--collect proc)
(unless (process-get proc 'flan-replies)
(accept-process-output proc 0.05))))
(unless got
(setq got (and (process-get proc 'flan-replies) t))
(when got (setq reply (flan--take-reply proc))))
(unless got
;; A header whose body never came is a promise about bytes that will
;; never be made good: reading on from here would take the *next*
;; reply's header as this one's payload, and every request after it
;; would be answered by the one before. The frame is dead, so it is
;; dropped. A header that has not arrived in full is left, being a
;; valid prefix of a frame still on its way.
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
(when (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
(erase-buffer))))
(flan--no-reply proc))
reply))
;; Written by `flan--append-output' when a REPL is open; defined in
;; flan-repl.el, which requires this file, so the reference here has to be a
@ -353,6 +397,21 @@ Reconnecting happens before a send, never after one."
(bound-and-true-p flan-repl-buffer)
(get-buffer flan-repl-buffer)))
(defcustom flan-output-maximum-lines 5000
"Lines the daemon's buffer and the REPL keep; older lines are deleted.
A program that prints every frame would otherwise grow them without limit.
nil keeps everything."
:type '(choice integer (const :tag "No limit" nil)))
(defun flan--trim-lines ()
"Delete lines from the top of this buffer past `flan-output-maximum-lines'."
(when flan-output-maximum-lines
(save-excursion
(goto-char (point-max))
(when (zerop (forward-line (- flan-output-maximum-lines)))
(let ((inhibit-read-only t))
(delete-region (point-min) (line-beginning-position)))))))
(defun flan--append-output (text)
"Append TEXT, the running program's own output, where it can be read.
Two places. The daemon's log always gets it, so output lands somewhere
@ -365,6 +424,7 @@ open, above its prompt, which is where whoever is typing there is looking."
(save-excursion
(goto-char (point-max))
(insert text))
(flan--trim-lines)
;; Follow the tail only for someone who was already at it; a reader
;; scrolled back is reading something.
(when at-end (goto-char (point-max)))))
@ -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))))
reply)
(defvar flan-settle-hook nil
"Run before anything is sent, against the connection as it stands.
The protocol is one reply per request on one connection, and that is the whole
reason this exists. Anything that sends without waiting — the watch timer is
the only such thing — leaves a reply in flight that the *next* request would
otherwise read as its own. So a sender-in-flight hangs a function here that
collects its own reply first, and the invariant holds: exactly one request
outstanding, and every reply consumed by whoever asked for it.
Before the connection is checked, not after, and that ordering is the point.
An outstanding reply belongs to the connection it was asked on; if the daemon
has been restarted under Emacs, that connection is gone and no reply is coming
on the new one. Running this first is what lets a hook see that for itself
and drop its pending flag, rather than sitting out a full
`flan-reply-timeout' waiting on a socket the question was never asked
down.")
(defun flan--request (form)
"Send FORM to the connected program and return its reply."
;; `flan--busy' first of all, and around the reconnect as well as around
@ -522,7 +564,6 @@ down.")
;; middle of that would be a second conversation on the connection this one
;; just opened.
(let ((flan--busy t))
(run-hooks 'flan-settle-hook)
(let ((proc (flan--live-connection)))
(flan--absorb (progn (flan--send proc form)
(flan--read-reply proc))))))
@ -563,18 +604,10 @@ Set to nil to leave the program's state to whatever replies happen to say."
(let ((proc flan--connection)
(flan--busy t))
(ignore-errors
;; The same settle every other sender does, and for the same reason.
;; `flan--busy' is not enough on its own: the watch timer leaves a
;; request in flight and *clears* nothing, deliberately — it binds no
;; busy flag, because it never waits — so a poll that checked only the
;; flag would send `describe' with the watch's reply still coming and
;; read that instead. The two would then stay swapped for the rest of
;; the session, each consumer answering the other's question, which is
;; exactly the interleaving `flan-settle-hook' exists to prevent.
(run-hooks 'flan-settle-hook)
;; `describe' rather than `break': it is the cheap op, it is what
;; drains the program's output, and the state is on every reply anyway.
;; Asking `break' would fetch restart names nobody is choosing from.
;; `describe' rather than `break': it is the cheap op, and the state
;; is on every reply anyway. Asking `break' would fetch restart names
;; nobody is choosing from. The program's output does not wait for
;; this; the daemon pushes it as it is printed.
(flan--send proc '(:op "describe"))
(flan--absorb (flan--read-reply proc))))))
@ -611,14 +644,37 @@ Set to nil to leave the program's state to whatever replies happen to say."
(setq flan--connection
(make-network-process
:name "flan" :buffer buf :family 'local :service socket
:coding 'binary :noquery t))
:coding 'binary :noquery t
:filter #'flan--filter :sentinel #'flan--sentinel))
(setq flan--socket socket))
(setq flan--stopped nil)
(setq flan--parked nil)
;; Output and the watch table come as they happen from here on. A daemon
;; that does not know the op refuses it and nothing else changes.
(let ((flan--busy t))
(ignore-errors
(flan--send flan--connection '(:op "push" :on t))
(flan--absorb (flan--read-reply flan--connection))))
(flan--start-polling)
(force-mode-line-update t)
(run-hooks 'flan-connected-hook)
flan--connection)
(defvar flan-connected-hook nil
"Run after a connection to a daemon is opened, including a reconnect.")
(defvar flan-disconnected-hook nil
"Run when the current connection to the daemon closes.")
(defun flan--sentinel (proc _event)
"Notice PROC closing, when it is the current connection."
;; nil is `flan-disconnect', which clears the connection before the
;; sentinel runs; a different live process is a reconnect that replaced it.
(when (and (or (eq proc flan--connection) (null flan--connection))
(not (process-live-p proc)))
(force-mode-line-update t)
(with-demoted-errors "flan: %S" (run-hooks 'flan-disconnected-hook))))
;; A daemon restarted while Emacs was not looking is the ordinary case, not an
;; exceptional one: `flan dev' ends when its program does, and a program under
;; development exits all the time. So a dead connection is reopened on the
@ -1495,11 +1551,17 @@ no longer wrong."
;; The bare keys grep-mode and compilation-mode readers reach for. The
;; minor mode below provides RET, M-g M-n and M-g M-p; these two are the
;; major-mode half, possible because the buffer is read-only.
(define-key map (kbd "n") #'compilation-next-error)
(define-key map (kbd "p") #'compilation-previous-error)
(define-key map (kbd "n") #'next-error-no-select)
(define-key map (kbd "p") #'previous-error-no-select)
;; The minor mode's RET and `special-mode-map''s q, bound here as well so
;; that they are this mode's own keys and reach Evil's states.
(define-key map (kbd "RET") #'compile-goto-error)
(define-key map "q" #'quit-window)
map)
"Keymap for `flan-diagnostics-mode'.")
(flan-evil-own-keys 'flan-diagnostics-mode-map)
(define-derived-mode flan-diagnostics-mode special-mode "Flan-Diagnostics"
"Every message the compiler handed the editor, one navigable list.
`n' and `p' move between entries, RET goes to the line one names.
@ -2223,6 +2285,16 @@ in this program; C-c C-v describes it" (car d)))
(defvar flan-doc-buffer "*flan-doc*"
"Buffer `flan-doc' writes into.")
(defvar flan-doc-mode-map
(let ((map (make-sparse-keymap)))
;; `special-mode-map''s q, as this mode's own key so that it reaches
;; Evil's states; see `flan-evil-own-keys'.
(define-key map "q" #'quit-window)
map)
"Keys in `flan-doc-mode'.")
(flan-evil-own-keys 'flan-doc-mode-map)
(define-derived-mode flan-doc-mode special-mode "Flan-Doc"
"Mode for the buffer `flan-doc' writes.")
@ -2928,6 +3000,15 @@ does, until the same form is evaluated again without a prefix."
(defvar flan-disassembly-buffer "*flan-disassembly*"
"Buffer `flan-disassemble' writes into.")
(defvar flan-disassembly-mode-map
(let ((map (make-sparse-keymap)))
;; As `flan-doc-mode-map'.
(define-key map "q" #'quit-window)
map)
"Keys in `flan-disassembly-mode'.")
(flan-evil-own-keys 'flan-disassembly-mode-map)
(define-derived-mode flan-disassembly-mode special-mode "Flan-Disasm"
"Mode for the buffer `flan-disassemble' writes."
(setq-local truncate-lines t))
@ -2988,36 +3069,72 @@ tail of exactly one packaged name, because a buffer inside a package writes
(let ((inhibit-read-only t))
(erase-buffer)
(flan-disassembly-mode)
(let ((start (point)))
(insert (format "; %s for %s\n"
(if ir "LLVM IR" "disassembly") full))
(put-text-property start (point) 'face 'font-lock-comment-face))
(flan-disassemble--header "signature" (plist-get r :signature))
(flan-disassemble--header "source" (plist-get r :loc))
(flan-disassemble--header
"generation"
(let ((g (plist-get r :generation)))
(if (and (numberp g) (zerop g))
"0 (the build the program was launched from)"
(format "%s" g))))
(flan-disassemble--header "object" (plist-get r :object))
(flan-disassemble--header "showing" (plist-get r :basis))
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(let ((start (point)))
(insert (plist-get r :text))
;; The source lines the daemon placed in the listing, and the
;; headings in the IR, are `;' comments; shown as comments so the
;; code between them reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face))))
(flan-disassemble--render r (if ir "LLVM IR" "disassembly"))
(goto-char (point-min))))
(display-buffer flan-disassembly-buffer)))
(defun flan-disassemble--comment (text)
"Insert TEXT as a line drawn as a comment."
(let ((start (point)))
(insert text "\n")
(put-text-property start (point) 'face 'font-lock-comment-face)))
(defun flan-disassemble--render (r what)
"Insert the reply R into the current buffer; WHAT names the view.
A generic has no code of its own, only a copy per type it was called at.
The daemon answers its name with that copy's listing when there is one, and
with `:copies', one listing each, when there are several; each is headed by
the types its variables were bound to."
(let ((copies (plist-get r :copies)))
(if copies
(progn
(flan-disassemble--comment
(format "; %s for %s, one copy per type it is called at"
what (plist-get r :name)))
(flan-disassemble--header "signature" (plist-get r :signature))
(dolist (c copies)
(insert "\n")
(flan-disassemble--comment
(format ";; %s at %s" (plist-get c :generic) (plist-get c :types)))
(if (plist-get c :refused)
(progn
(flan-disassemble--header "signature" (plist-get c :signature))
(flan-disassemble--header "no listing" (plist-get c :refused)))
(flan-disassemble--listing c))))
(flan-disassemble--comment
(if (plist-get r :generic)
(format "; %s for %s at %s" what (plist-get r :generic)
(plist-get r :types))
(format "; %s for %s" what (plist-get r :name))))
(flan-disassemble--listing r))))
(defun flan-disassemble--listing (r)
"Insert one function's headers and listing out of the reply R."
(flan-disassemble--header "signature" (plist-get r :signature))
(flan-disassemble--header "source" (plist-get r :loc))
(flan-disassemble--header
"generation"
(let ((g (plist-get r :generation)))
(if (and (numberp g) (zerop g))
"0 (the build the program was launched from)"
(format "%s" g))))
(flan-disassemble--header "object" (plist-get r :object))
(flan-disassemble--header "showing" (plist-get r :basis))
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(let ((start (point)))
(insert (plist-get r :text))
(unless (bolp) (insert "\n"))
;; The source lines the daemon placed in the listing, and the headings in
;; the IR, are `;' comments; shown as comments so the code between them
;; reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face)))))
;;;###autoload
(defun flan-disassemble-ir (name)
"Show the LLVM IR NAME's installed body was built from.

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-previous-line-first-non-blank)))
(test-flan--check (format "under Evil, %s is still Evil's" (car k))
(eq (key-binding (kbd (car k))) (cdr k)))))
(eq (key-binding (kbd (car k))) (cdr k))))
;; The other buffers of Flan's own: every key a mode's map binds
;; itself does what it does without Evil, and the keys it does not
;; bind stay Evil's.
(require 'flan-lower)
(require 'flan-watch)
(dolist (m '((flan-inspect-mode . flan-inspect-mode-map)
(flan-watch-mode . flan-watch-mode-map)
(flan-doc-mode . flan-doc-mode-map)
(flan-disassembly-mode . flan-disassembly-mode-map)
(flan-diagnostics-mode . flan-diagnostics-mode-map)
(flan-lower-mode . flan-lower-mode-map)))
(let ((b (get-buffer-create (format " *evil-%s*" (car m))))
(own nil))
(map-keymap-internal
(lambda (key def) (when (commandp def) (push (cons key def) own)))
(symbol-value (cdr m)))
(switch-to-buffer b)
(funcall (car m))
(evil-initialize-state)
(test-flan--check (format "%s binds keys of its own" (car m)) own)
(dolist (k own)
(test-flan--check
(format "under Evil, %s in %s is the mode's"
(key-description (vector (car k))) (car m))
(eq (key-binding (vector (car k))) (cdr k))))
(dolist (k '(("h" . evil-backward-char) ("SPC" . evil-forward-char)
("<" . evil-shift-left)
("-" . evil-previous-line-first-non-blank)))
(test-flan--check (format "under Evil, %s in %s is still Evil's"
(car k) (car m))
(eq (key-binding (kbd (car k))) (cdr k))))
(kill-buffer b))))
(evil-mode -1))))
(message "\n%d checks, %d failures" test-flan--ran test-flan--failures)

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"
(and (null flan-watch--consumers) torn))))
;; --- The reset is guarded on the stop ------------------------------------
;; --- Pushes and replies on one connection ---------------------------------
;;
;; `flan-watch--tick' asks for "since you last looked" by sending `:reset t'
;; beside the read. A stopped program takes no samples, so there is no window
;; for a reset to close and none for it to open — and the runtime's lazy clear
;; is what keeps a paused program showing the numbers from the moment you
;; paused it. So the tick must drop `:reset' while stopped and keep reading.
;;
;; Asserted at the level the rest of this file works at: no daemon, no socket.
;; The tick is a function from `flan--stopped' to the form it puts on the
;; wire, and that is the whole claim, so `flan--send' and `process-live-p'
;; are stubs. What this cannot reach is the daemon actually honouring the
;; absent field; `test/test_dev.ml' drives a real program for that.
;; The daemon writes two kinds of frame: replies, and pushes it sends without
;; being asked — output as it is printed, the watch table while it is armed.
;; The filter handles a push as it arrives and queues a reply for whoever is
;; waiting. Frames are written into a pipe process's buffer by hand, split
;; mid-frame the way a socket may deliver them, so what is claimed is the
;; reader and not the daemon.
(defun test-flan-watch--tick-form (stopped)
"The form `flan-watch--tick' sends with the program STOPPED or not."
(let ((sent nil)
(flan--stopped stopped)
(flan--connection 'a-process)
(flan--busy nil)
(flan-watch--pending nil)
;; Not `buffer': that consumer checks for a live watch buffer first and
;; would drop the subscription instead of ticking.
(flan-watch--consumers '(ghost)))
(cl-letf (((symbol-function 'process-live-p) (lambda (_) t))
((symbol-function 'flan--take-reply) (lambda (_) nil))
((symbol-function 'flan--send)
(lambda (_proc form) (setq sent form))))
(flan-watch--tick)
(list sent flan-watch--pending))))
(defun test-flan-watch--frame (form)
"FORM framed as the daemon frames it."
(let ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
(format "%d\n%s" (length payload) payload)))
(let ((running (test-flan-watch--tick-form nil))
(stopped (test-flan-watch--tick-form "BoundsError")))
(test-flan--check
"a tick while the program runs asks for the window it is closing"
(equal (nth 0 running) '(:op "watch" :reset t)))
(test-flan--check
"a tick while the program is stopped sends no reset"
(null (plist-get (nth 0 stopped) :reset)))
;; Skipping the tick outright would be worse than resetting: the watch would
;; freeze at whatever it held when the program stopped, and a break loop is
;; exactly when the numbers are being read.
(test-flan--check
"but it still reads the table"
(equal (plist-get (nth 0 stopped) :op) "watch"))
(test-flan--check
"and still has a reply in flight, so the cycle survives the pause"
(and (nth 1 running) (nth 1 stopped))))
(let* ((buf (generate-new-buffer " *flan-push-test*"))
(proc (make-pipe-process :name "flan-push-test" :buffer buf
:noquery t))
(painted nil)
(appended nil)
(flan-watch--consumers '(ghost)))
(with-current-buffer buf (set-buffer-multibyte nil))
(unwind-protect
(cl-letf (((symbol-function 'flan-watch--absorb)
(lambda (r) (push r painted)))
((symbol-function 'flan--append-output)
(lambda (text) (push text appended))))
(let ((flan-push-functions '(flan-watch--on-push))
(stream
(concat
(test-flan-watch--frame '(:push "output" :status "ok"
:output "héllo\n"))
(test-flan-watch--frame '(:status "ok" :value "42"))
(test-flan-watch--frame '(:push "watch" :status "ok"
:watch (("ticks" "7"))
:overflow nil)))))
;; In three pieces, the first ending inside the first frame's body.
(flan--filter proc (substring stream 0 12))
(test-flan--check "a push is not handled before all of it has arrived"
(null appended))
(flan--filter proc (substring stream 12 40))
(flan--filter proc (substring stream 40))
(test-flan--check "an output push reaches the output as it arrives"
(equal appended
(list (decode-coding-string
(encode-coding-string "héllo\n" 'utf-8)
'utf-8))))
(test-flan--check "a watch push behind a reply is painted without waiting for the reply to be read"
(equal (plist-get (car painted) :watch)
'(("ticks" "7"))))
(test-flan--check "and the reply is kept for the request that asked"
(equal (flan--take-reply proc)
'(:status "ok" :value "42")))
(test-flan--check "and taken once"
(null (flan--take-reply proc)))
(let ((flan-watch--consumers nil))
(flan--filter proc (test-flan-watch--frame
'(:push "watch" :status "ok" :watch nil)))
(test-flan--check "a watch push with nothing watching paints nothing"
(= 1 (length painted))))))
(delete-process proc)
(kill-buffer buf)))
;; The daemon's buffer keeps `flan-output-maximum-lines' and loses the oldest.
(let ((flan-daemon-buffer " *flan-trim-test*")
(flan-output-maximum-lines 10))
(unwind-protect
(progn
(dotimes (i 30) (flan--append-output (format "line %d\n" i)))
(with-current-buffer flan-daemon-buffer
(test-flan--check "the daemon's buffer is kept to its line limit"
(<= (count-lines (point-min) (point-max)) 10))
(test-flan--check "and keeps the newest lines"
(and (string-match-p "line 29" (buffer-string))
(not (string-match-p "line 0\n" (buffer-string)))))))
(kill-buffer flan-daemon-buffer)))
(provide 'test-flan-watch)
;;; test-flan-watch.el ends here

250
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
;; buffer — no REPL is open yet, and the log is the fallback that makes a
;; println never depend on one.
;;
;; And it arrives without anything being asked. The poll is stopped and no
;; request is sent while this waits, so the only way HELLO can reach the
;; buffer is the daemon pushing it.
(flan--eval "(defn step [] i64 (do (println \"HELLO\") ticks))" "form")
(let ((seen nil) (deadline (+ (float-time) 10)))
(while (and (not seen) (< (float-time) deadline))
(ignore-errors (flan--request '(:op "describe")))
(setq seen (with-current-buffer (get-buffer-create flan-daemon-buffer)
(string-match-p "HELLO" (buffer-string)))))
(test-flan--check "the program's output reaches the daemon's buffer" seen))
(flan--stop-polling)
(with-current-buffer (get-buffer-create flan-daemon-buffer)
(let ((inhibit-read-only t)) (erase-buffer)))
(let* ((pushes 0)
(count (lambda (frame)
(when (equal (plist-get frame :push) "output")
(setq pushes (1+ pushes)))))
(started (float-time))
(seen nil))
(advice-add 'flan--dispatch-push :before count)
(unwind-protect
(progn
(while (and (not seen) (< (float-time) (+ started 10)))
(accept-process-output flan--connection 0.01)
(setq seen (with-current-buffer flan-daemon-buffer
(string-match-p "HELLO" (buffer-string)))))
;; 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 ──────────────────────────────────
;;
@ -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
;; it back without compiling anything. What is left to prove here is the
;; part that is only true in Emacs, and it is not the painting — it is that
;; an *asynchronous* sender and the ordinary synchronous request can share one
;; connection.
;;
;; The protocol is one reply per request on one socket. The watch timer
;; sends and does not wait, deliberately, because waiting on a 0.2s timer
;; stalls the UI. That leaves a reply in flight that the next C-c C-c would
;; read as its own — an evaluation reporting the watch table's answer, which
;; is the exact bug `flan-settle-hook' exists to make impossible. This
;; program writes nothing into the table, which does not matter: the
;; interleaving is the claim.
(flan-watch)
(test-flan--check "the watch buffer opens" (get-buffer flan-watch-buffer))
(test-flan--check "and the timer is running" flan-watch--timer)
(test-flan--check "a program that watches nothing says so, rather than looking broken"
(with-current-buffer flan-watch-buffer
(string-match-p "nothing is being watched" (buffer-string))))
;; The tick by hand, so this does not depend on a timer firing inside a batch
;; run. Two of them: the first sends, the second collects and sends again.
(flan-watch--tick)
(test-flan--check "a tick leaves a request in flight rather than waiting for it"
flan-watch--pending)
;; The background poll is a sender too, and it was the one sender that did
;; not settle: it guarded on `flan--busy' alone, which the watch timer
;; deliberately does not bind — it never waits, so it has nothing to hold —
;; and sent `describe' straight into a connection that already owed a reply.
;; It then read the watch's answer as its own, and the two stayed swapped
;; for the rest of the session. The second check is where that would show:
;; a `describe' answered by the watch table has no `:fns' in it at all.
(flan--poll)
(test-flan--check "a poll settles the watch's reply rather than reading it as its own"
(null flan-watch--pending))
(test-flan--check "and the request after it is still answered by its own reply"
;; part that is only true in Emacs: the daemon sends the table on the same
;; connection that carries replies, unasked, and neither gets in the way of
;; the other.
(let ((pushes 0))
(let ((count (lambda (_r) (setq pushes (1+ pushes)))))
(advice-add 'flan-watch--absorb :before count)
(unwind-protect
(progn
(flan-watch)
(test-flan--check "the watch buffer opens" (get-buffer flan-watch-buffer))
(test-flan--check "a program that watches nothing says so, rather than looking broken"
(with-current-buffer flan-watch-buffer
(string-match-p "nothing is being watched" (buffer-string))))
;; A body that writes the table, so there is something to send.
(flan--eval "(defn step [] i64 (set ticks (+ ticks 1)) (watch \"ticks\" ticks) ticks)"
"form")
(let ((until (+ (float-time) 5)))
(while (and (< (float-time) until)
(not (with-current-buffer flan-watch-buffer
(string-match-p "^ticks" (buffer-string)))))
(accept-process-output flan--connection 0.05)))
(test-flan--check "the table arrives without being asked for"
(with-current-buffer flan-watch-buffer
(string-match-p "^ticks [0-9]+" (buffer-string))))
;; And again, unasked, rather than once.
(setq pushes 0)
(let ((until (+ (float-time) 10)))
(while (and (< pushes 2) (< (float-time) until))
(accept-process-output flan--connection 0.05)))
(test-flan--check "and keeps arriving" (>= pushes 2)))
(advice-remove 'flan-watch--absorb count))))
;; Replies are not disturbed by the pushes around them.
(test-flan--check "a request while the table is being pushed gets its own reply"
(member "step" (plist-get (flan--request '(:op "describe"))
:fns)))
;; And the same hook against a daemon restarted under an armed watch. The
;; reply the watch is owed was asked for on the connection that has gone, so
;; there is nothing to wait for — running the hook before the connection is
;; checked is what lets it see that. Asking after the reconnect meant a
;; whole `flan-reply-timeout' of frozen Emacs on the first thing anybody
;; typed after a restart, which is why the wait itself is what is measured.
(flan-watch--tick)
;; A daemon restarted under an armed watch: the new connection arms it again.
(delete-process flan--connection)
;; The timeout and the assertion are deliberately different numbers: what is
;; being told apart is a request that waited one out from a request that did
;; not, and the wider the gap the less this depends on how loaded the machine
;; running the suite happens to be. A reconnect and a `describe' are
;; milliseconds of work.
(let ((flan-reply-timeout 10)
(started (float-time)))
(let ((r (flan--request '(:op "describe"))))
(test-flan--check "a request after a restart does not wait out a reply the old connection owed"
(and (member "step" (plist-get r :fns))
(< (- (float-time) started) 3)))
(test-flan--check "and the watch is not left waiting for one either"
(null flan-watch--pending))))
;; A request in flight again, for the interleaving below.
(flan-watch--tick)
;; And now the interleaving, with a reply outstanding on purpose. If the
;; settle hook were not there this would return the watch table's plist and
;; `flan--report' would take its missing :status for a rejection.
;;
(let ((r (flan--request '(:op "describe"))))
(test-flan--check "after a reconnect the request is answered"
(member "step" (plist-get r :fns))))
(with-current-buffer flan-watch-buffer
(let ((inhibit-read-only t)) (erase-buffer)))
(let ((until (+ (float-time) 5)))
(while (and (< (float-time) until)
(not (with-current-buffer flan-watch-buffer
(string-match-p "^ticks" (buffer-string)))))
(accept-process-output flan--connection 0.05)))
(test-flan--check "and the table is pushed again on the new connection"
(with-current-buffer flan-watch-buffer
(string-match-p "^ticks" (buffer-string))))
;; Back in the source buffer first: `flan-doc' and `flan-watch' above both
;; display buffers of their own, and C-c C-c reads the buffer it is run in.
(pop-to-buffer (flan--buffer-visiting file))
@ -1404,31 +1435,24 @@ already rely on it — so nothing here is a stand-in for the real thing."
(search-forward "(defn step")
(goto-char (match-beginning 0))
(let ((said (test-flan--said (flan-eval-defun))))
(test-flan--check "an eval with a watch reply in flight still gets its own answer"
(and said (string-match-p "step" said)))
(test-flan--check "and the watch request was settled, not abandoned"
(null flan-watch--pending)))
(flan-watch--tick)
(flan-watch--tick)
(test-flan--check "and the buffer keeps painting afterwards"
(with-current-buffer flan-watch-buffer
(> (buffer-size) 0)))
(test-flan--check "an eval while the table is being pushed gets its own answer"
(and said (string-match-p "step" said))))
;; Point survives a repaint. This is why `replace-buffer-contents' is used
;; rather than erase-and-insert: the latter would put the cursor back at the
;; top of the buffer on every tick, which makes the one thing you want to do
;; in a watch buffer — look at a line while the program runs — impossible.
;; top of the buffer on every repaint, which makes the one thing you want to
;; do in a watch buffer — look at a line while the program runs — impossible.
(with-current-buffer flan-watch-buffer
(flan-watch--absorb '(:status "ok" :watch (("ticks" "1")) :overflow nil))
(goto-char (point-max))
(let ((where (point)))
(flan-watch--tick)
(flan-watch--tick)
(flan-watch--absorb '(:status "ok" :watch (("ticks" "2")) :overflow nil))
(test-flan--check "and point does not jump to the top on a repaint"
(= (point) where))))
(flan-watch-stop)
(test-flan--check "stopping cancels the timer" (null flan-watch--timer))
(test-flan--check "and takes the settle hook off with it"
(not (memq #'flan-watch--settle flan-settle-hook)))
;; Killing the buffer is how it is closed, and it disarms the table.
(kill-buffer flan-watch-buffer)
(test-flan--check "killing the watch buffer ends the subscription"
(and (null flan-watch--consumers)
(not (memq #'flan-watch--on-push flan-push-functions))))
(flan-disconnect)
(test-flan--check "disconnected" (not (process-live-p flan--connection)))
@ -1798,6 +1822,44 @@ already rely on it — so nothing here is a stand-in for the real thing."
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "not a function" raised))))
;; A generic has no code under its own name, only a copy per type it is
;; called at, so its name is answered with those: refused while there are
;; none, and one listing per copy, each headed by its types, once there
;; are several. Sent from a file that is not the program's.
(let ((file (concat socket3 "-sorts.flan")))
(flan--request
(list :op "eval" :file file
:code "(defn selection-sort [xs [$t]] ()
{:where (ordered? $t)}
(dotimes [i (length xs)]
(let [m i]
(dotimes [j (length xs)]
(when (< (at xs j) (at xs m)) (set m j)))
(swap xs i m))))"))
(test-flan--check "a generic nothing calls yet is refused, saying why"
(let ((raised nil))
(condition-case err (flan-disassemble "selection-sort" t)
(user-error (setq raised (error-message-string err))))
(and raised
(string-match-p "is generic" raised)
(string-match-p "no code has been made" raised))))
(flan--request
(list :op "eval" :file file
:code "(defn use-sort [] ()
(let [a [3 1 2]] (selection-sort (slice a 0 3)))
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"))
(flan-disassemble "selection-sort" t)
(with-current-buffer flan-disassembly-buffer
(let ((text (buffer-string)))
(test-flan--check "a generic's IR is shown copy by copy"
(and (string-match-p "\\`; LLVM IR for selection-sort, one copy" text)
(string-match-p "^;; selection-sort at \\$t = i32$" text)
(string-match-p "^;; selection-sort at \\$t = f64$" text)
(string-match-p "^define .*flan\\.selection-sort-i32" text)
(string-match-p "^define .*flan\\.selection-sort-f64" text)))
(test-flan--check "each copy names the file the generic was sent from"
(string-match-p (regexp-quote file) text)))))
(flan-quit)
(ignore-errors (delete-file socket3)))
@ -1817,6 +1879,30 @@ already rely on it — so nothing here is a stand-in for the real thing."
;; anything being shut at all. `invisible-p' is the predicate that means
;; what it says, and it means it whether outline folded with an overlay or
;; with a text property.
;;
;; A generic is compiled only as its copies, so its own name finds nothing
;; and each copy is shown under a line naming it. A function that merely
;; shares the prefix and was written elsewhere is not a copy.
(with-temp-buffer
(let ((flan--defs
'(("sort" "fn" "sort [[$t]] ()" "<prelude>:331:7" "")
("sort-i32" "fn" "sort-i32 [[i32]] ()" "<prelude>:331:7" "")
("sort-f64" "fn" "sort-f64 [[f64]] ()" "<prelude>:331:7" "")
("sort-bytes" "fn" "sort-bytes [[[u8]]] ()" "<prelude>:1595:7" "")))
(flan-lower-fetch-function
(lambda (section _file name _flags)
(unless (equal name "sort") (format "%s of %s\n" section name))))
(flan-lower--file "x.flan")
(flan-lower--name "sort")
(flan-lower--flags nil)
(flan-lower--texts nil))
(flan-lower--gather '(ir))
(let ((text (alist-get 'ir flan-lower--texts)))
(test-flan--check "a generic's lowering is each of its copies, named"
(and (string-match-p "^;; sort-f64\nir of sort-f64$" text)
(string-match-p "^;; sort-i32\nir of sort-i32$" text)
(not (string-match-p "sort-bytes" text)))))))
(let* ((flan-lower--state (copy-alist flan-lower--state))
(flan-lower-fetch-function
(lambda (section _file name _flags)

103
lib/check.ml
View File

@ -407,6 +407,37 @@ let spell_arg stand_for (a : Ast.expr) =
| Ast.UInt (_, s) -> s
| _ -> stand_for
(* Operators other languages spell differently, each mapped to the Flan
builtin that computes the same thing. Only exact equivalents: [mod] is left
out because Clojure's is floored and [%] is not. *)
let operator_aliases =
[ ("not=", ("!=", "Not-equal")); ("=/=", ("!=", "Not-equal"));
("/=", ("!=", "Not-equal")); ("<>", ("!=", "Not-equal"));
("==", ("=", "Equality")); ("===", ("=", "Equality"));
("&&", ("and", "Logical and")); ("||", ("or", "Logical or"));
("!", ("not", "Logical not")) ]
(* The fix, as the sentence that ends the refusal. The reader's call is
written back out under the Flan name only when every argument can be
spelled and the count is one the builtin takes, so a suggestion printed as
code compiles once pasted. An argument that cannot be spelled leaves the
call as it was, with only the name to change; a count the builtin does not
take gets the builtin's shape. *)
let alias_fix flan (args : Ast.expr list) =
let spelled = List.map (spell_arg "") args in
let n = List.length args in
let arity_ok =
match flan with
| "not" -> n = 1
| "and" | "or" -> true
| _ -> n >= 2
in
if not arity_ok then
Printf.sprintf "It is called as %s"
(if flan = "not" then "(not x)" else "(" ^ flan ^ " x y)")
else if List.mem "" spelled then Printf.sprintf "Write %s in its place" flan
else Printf.sprintf "Write (%s)" (String.concat " " (flan :: spelled))
(* What a [break] or a [continue] may be talking about, innermost first.
[Lloop] is a loop it is lexically inside, carrying its label if it was given
@ -1212,6 +1243,21 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t =
[Types.t] and therefore to the layout calculator, both backends,
[Render] and the DWARF path. docs/SPIKE-GENERICS.md, question 4,
prices it and leaves it out. *)
(* A head that is not a type at all but one edit from one is the typo
[(Vect i32)], and the generics sentence would answer a question
nobody asked. *)
let constructors = [ "Ptr"; "Option"; "Vec"; "Map" ] in
(match
if Hashtbl.mem env.aliases name || Hashtbl.mem env.structs name
|| Hashtbl.mem env.datas name || Hashtbl.mem env.unions name
|| Hashtbl.mem env.enums name
then None
else near_miss env ~also:constructors name
with
| Some m when List.mem m constructors ->
Loc.failk "check/unknown-type" loc
"unknown type %s — did you mean %s?" name m
| _ -> ());
fail loc
"%s takes no type arguments. A generic function is written with $t \
in its parameter vector; a generic type is not there yet"
@ -1411,6 +1457,53 @@ let is_type_name env n =
slot holding one is a type however few of them there are. *)
|| (n <> "" && n.[0] = '$')
(* A defn written without its return type puts the body's first form in the
slot, and [(dotimes [i n] ...)] parses as a type application. Every type
application's head is a constructor, and a constructor is capitalised, so a
lowercase head there — or the name of a function — is a body form and not a
malformed type. A capitalised head that is neither stays with [resolve],
whose unknown-type and no-type-arguments sentences are the right ones for
[(Vect i32)] and [(Pair i32)]. *)
let missing_return_type env (fn : Ast.fn) =
match fn.Ast.ret with
| Some { Ast.t = Ast.Tapp (head, args); tloc } ->
let lowercase =
head <> "" && not (head.[0] >= 'A' && head.[0] <= 'Z')
in
let constructor =
List.mem head [ "Ptr"; "Option"; "Vec"; "Map"; "Result" ]
in
(* [(vec i32)] is the constructor with the wrong case, not a body form —
but only while every argument is a type, since [(map inc xs)] is a
body form whose head is a function. *)
let args_are_types =
List.for_all
(fun (a : Ast.texpr) ->
match a.Ast.t with Ast.Tname n -> is_type_name env n | _ -> true)
args
in
(match
List.find_opt
(fun c -> String.lowercase_ascii c = String.lowercase_ascii head
&& c <> head)
[ "Ptr"; "Option"; "Vec"; "Map" ]
with
| Some c when args_are_types && not (is_type_name env head) ->
Loc.failk "check/unknown-type" tloc
"unknown type %s — did you mean %s?" head c
| _ -> ());
if (not constructor) && (not (is_type_name env head))
&& (lowercase || Hashtbl.mem env.fns head
|| List.mem head !builtin_names)
then
Loc.failk "check/return-type-missing" tloc
"%s has no return type: (%s ...) stands where the return type goes, \
and %s is not a type. The return type is written between the \
parameter vector and the body, and a function that returns nothing \
writes () there"
fn.Ast.name head head
| _ -> ()
(* Before a bare symbol is allowed to become an unannotated parameter, the two
ways it is more likely to be a type that went wrong.
@ -9370,6 +9463,15 @@ and ordinary_call ctx ~want loc name args =
name dname dname c.Tast.vname dname c.Tast.vname
else if Hashtbl.mem ctx.env.structs name then
positional_struct ctx ~want loc name args
else if List.mem_assoc name operator_aliases then
(* Asked before the package test, because [/=] and [=/=] have a slash
in them and are not package calls. The did-you-mean cannot reach
these: [not=] is one edit from [not], which is the wrong answer,
and [&&] is no edit at all from [and]. *)
let flan, what = List.assoc name operator_aliases in
Loc.failk "check/unknown-function" loc
"there is no %s. %s is %s. %s" name what flan
(alias_fix flan args)
else if String.contains name '/' then
unimplemented loc
(Printf.sprintf "the call %s into an imported package" name) 4
@ -10995,6 +11097,7 @@ let collect env (decls : Ast.decl list) =
let fields = List.map field ms in
Hashtbl.replace env.unions n { Tast.sname = n; fields }
| Ast.Defn fn ->
missing_return_type env fn;
(* A signature that introduces a type variable is a *pattern*, not a
signature: it goes in [gsigs] and the function goes nowhere near
[fns], because nothing can be called at [t]. Every call site turns

404
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
[remove_session_dirs]. *)
mutable died : Unix.process_status option;
(* Bytes of program output dropped from the front of [out] because it grew
past [capacity] before anything read it. Said once, in the output, by
[take]. *)
mutable dropped : int;
}
(* The program's stdout is a pipe into this process, so that an editor can see
@ -97,6 +101,7 @@ let drain t =
(* Bounded: a program that prints every frame must not grow this
process without limit. The newest text is the useful end. *)
if Buffer.length t.out > capacity then begin
t.dropped <- t.dropped + (Buffer.length t.out - capacity);
let keep = Buffer.sub t.out (Buffer.length t.out - capacity) capacity in
Buffer.clear t.out;
Buffer.add_string t.out keep
@ -112,7 +117,14 @@ let take t =
drain t;
let s = Buffer.contents t.out in
Buffer.clear t.out;
s
if t.dropped = 0 then s
else begin
let n = t.dropped in
t.dropped <- 0;
Printf.sprintf
"[flan dev: %d bytes of the program's output were dropped; the editor \
was not reading fast enough]\n%s" n s
end
let await ?(ms = 5000) f =
let rec go ms =
@ -620,6 +632,59 @@ let host_loc t name =
| Some f -> Loc.to_string f.Tast.floc
| None -> ""
(* A generic is never a [Tast.fn]: the checker keeps it as the AST it was
written as, and each type it is called at makes an ordinary copy under a
name of its own ([selection-sort-i32]). So a by-name op asked for the name
that was written finds nothing in the program, and these are how it gets
from that name to what the program does hold. *)
(* Its signature as written, [$] and all — [Types.to_string] prints a variable
bare, and [[t]] is not how anyone wrote it. *)
let generic_signature t name =
match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with
| None -> None
| Some (vars, params, ret) ->
let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in
let show ty = Types.to_string (Check.subst_ty dollar ty) in
Some
(Printf.sprintf "%s [%s] %s" name
(String.concat " " (List.map show params)) (show ret))
(* The copies of generic [name] the program holds, each with the types its
variables were bound to, spelled [$t = i32]. Read off the program: a copy
a [C-x C-e] made is kept in it, and [eval_expr] records the thunk's module
as that copy's owner, since no other module defines it. *)
let generic_copies t name =
let env = t.session.Session.env in
match Hashtbl.find_opt env.Check.gsigs name with
| None -> []
| Some (vars, params, ret) ->
List.filter_map
(fun (f : Tast.fn) ->
if f.Tast.fparent <> None then None
else
match Check.instantiation_origin env f.Tast.name with
| Some (g, ps) when String.equal g name ->
let subst = ref [] in
if List.length ps = List.length params then
ignore
(List.for_all2 (Check.bind_ty ~widen:true subst) params ps
&& Check.bind_ty subst ret f.Tast.ret);
let bound =
List.map
(fun v ->
match List.assoc_opt v !subst with
| Some ty -> Printf.sprintf "$%s = %s" v (Types.to_string ty)
| None -> "$" ^ v)
vars
in
Some (f, String.concat ", " bound)
| _ -> None)
t.session.Session.program.Tast.fns
(* By the types, alphabetically — [f64] before [i32] — so a listing asked
for twice is in the same order whatever order the copies were made in. *)
|> List.sort (fun (_, a) (_, b) -> String.compare a b)
(* ── Ops ───────────────────────────────────────────────────────────── *)
(* Every reply is a plist with a :status, so an editor can dispatch on one key
@ -1073,6 +1138,9 @@ let eval_expr t ~code ~origin ~pause =
the same instantiation would list it as already there. *)
let held = Session.held t.session in
let refused msg = Session.restore t.session held; error msg in
let had =
List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns
in
match Session.eval_expr ~origin ~pause t.session code with
| c ->
let before = match result t with Some (g, _) -> g | None -> 0L in
@ -1104,10 +1172,32 @@ let eval_expr t ~code ~origin ~pause =
let entered_gen = stop_gen t in
t.n <- t.n + 1;
let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
(* A generic called at a new type makes a copy that is defined in this
thunk's module and in no other, so this module is where [disassemble]
has to look for it — and its IR is kept for the reason [eval] keeps
a module's. *)
let ll =
Filename.concat t.dir (Printf.sprintf "e%d%s" t.n (module_ext c))
in
write_file ll c.Session.ir;
let copies =
List.filter_map
(fun (f : Tast.fn) ->
if List.mem f.Tast.name had then None else Some f.Tast.name)
t.session.Session.program.Tast.fns
in
(match build_module c ~debug:t.session.Session.debug ~out with
| _ ->
(match deliver t out with
| "ok" ->
if copies <> [] then begin
t.gen <- t.gen + 1;
List.iter
(fun n ->
Hashtbl.replace t.owners n
{ ogen = t.gen; oso = out; oll = ll; oloc = fn_loc t n })
copies
end;
(* Strictly after the delivery, and that ordering is the whole of
it: the sleeper is woken to look at a ring, so waking it before
the module is in one buys an empty poll and a five-second wait.
@ -1671,10 +1761,27 @@ let defs t =
(fun (name, sign, doc) -> entry ~name ~kind:"builtin" ~sign ~loc:"" ~doc ())
Check.builtins
in
(* A generic by the name it was written under. The program holds only its
copies, so without these rows the name an author typed was the one name
completion, eldoc and [M-.] had never heard of. Kind [fn], because it is
one to every reader of this list: it is called, jumped to, and
disassembled — the last through [disassemble], which answers a generic's
name with its copies. *)
let generics =
Hashtbl.fold
(fun name (g : Ast.fn) acc ->
entry ~name ~kind:"fn"
~sign:(Option.value ~default:name (generic_signature t name))
~loc:(Loc.to_string g.Ast.nloc) ()
:: acc)
t.session.Session.env.Check.generics []
|> List.sort compare
in
ok
[ ":defs "
^ Wire.list
(fns @ macros @ types @ globals @ externs @ prelude_macros @ builtins)
(fns @ generics @ macros @ types @ globals @ externs @ prelude_macros
@ builtins)
]
(* [(:op "layout" :type T)] — a struct's fields and their types.
@ -3795,22 +3902,9 @@ let kind_of t name =
then Some "an extern"
else None
let disassemble t ~name ~form =
if form <> "ir" && form <> "asm" then
error
(Printf.sprintf
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
else
match find_fn t name with
| None ->
(match kind_of t name with
| Some k ->
error
(Printf.sprintf
"%s is %s, not a function: there is no generated code to show for it"
name k)
| None -> error (Printf.sprintf "no function named %s in this session" name))
| Some f ->
(* The fields of one function's listing, or why there is none. [name] is the
symbol the code was built under, which for a generic's copy is the copy's. *)
let disassemble_fn t ~name ~form (f : Tast.fn) =
let o, why = basis t name in
let common =
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
@ -3831,7 +3925,7 @@ let disassemble t ~name ~form =
it cannot answer rather than failing at the text of an answer it was
never going to find. *)
if form = "ir" && t.session.Session.x86 then
error
Error
"this session was compiled by the x86 dev backend, so there is no \
LLVM IR to show — the listing it produced is assembly. C-c C-a \
disassembles the object, which works here; for the IR view, restart \
@ -3841,13 +3935,13 @@ let disassemble t ~name ~form =
| text ->
(match ir_of ~ir:text name with
| Some body ->
ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
Ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
| None ->
error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
Error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
| exception Sys_error m ->
error ("the IR this body was built from is gone: " ^ m)
Error ("the IR this body was built from is gone: " ^ m)
else if not (Sys.file_exists o.oso) then
error ("the object this body was linked into is gone: " ^ o.oso)
Error ("the object this body was linked into is gone: " ^ o.oso)
else
(* The kept source is what the source lines come from: the assembly's
map on x86, the [.ll]'s headings for an LLVM line table. Missing is
@ -3875,12 +3969,75 @@ let disassemble t ~name ~form =
"source interleaving needs line tables, which an LLVM \
session has only when started with flan dev --llvm --debug" ]
in
ok
Ok
(common
@ [ ":object " ^ Wire.quote o.oso ]
@ note
@ [ ":text " ^ Wire.quote text ])
| Error m -> error m
| Error m -> Error m
(* A generic's name answers with its copies: one is shown as any function is,
with [:generic] and [:types] beside it, and several come back as
[:copies], a list of those replies, one per type it was called at. *)
let disassemble t ~name ~form =
if form <> "ir" && form <> "asm" then
error
(Printf.sprintf
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
else
match find_fn t name with
| Some f ->
(match disassemble_fn t ~name ~form f with
| Ok fields -> ok fields
| Error m -> error m)
| None when Check.is_generic t.session.Session.env name ->
let sign = Option.value ~default:name (generic_signature t name) in
let copy ((f : Tast.fn), bound) =
Result.map
(fun fields ->
fields
@ [ ":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound ])
(disassemble_fn t ~name:f.Tast.name ~form f)
in
(match generic_copies t name with
| [] ->
error
(Printf.sprintf
"%s is generic — %s — and nothing in this session calls it \
yet, so no code has been made for it. Each type it is called \
at gets its own compiled copy: evaluate a function that calls \
it, then disassemble %s again"
name sign name)
| [ c ] ->
(match copy c with Ok fields -> ok fields | Error m -> error m)
| cs ->
(* One copy that cannot be shown is that copy's entry, named with
the reason, and not the whole reply: the others still have code
to read. *)
let entry (((f : Tast.fn), bound) as c) =
match copy c with
| Ok fields -> Wire.list fields
| Error m ->
Wire.list
[ ":name " ^ Wire.quote f.Tast.name;
":signature " ^ Wire.quote (signature_of_fn f);
":loc " ^ Wire.quote (fn_loc t f.Tast.name);
":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound;
":refused " ^ Wire.quote m ]
in
ok
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
":generic " ^ Wire.quote name;
":signature " ^ Wire.quote sign;
":copies " ^ Wire.list (List.map entry cs) ])
| None ->
(match kind_of t name with
| Some k ->
error
(Printf.sprintf
"%s is %s, not a function: there is no generated code to show for it"
name k)
| None -> error (Printf.sprintf "no function named %s in this session" name))
(* ── The watch table ───────────────────────────────────────────────── *)
@ -4260,6 +4417,13 @@ let handle t req =
in
disassemble t ~name ~form
| None -> error "disassemble needs :name")
(* Whether this connection is written to without asking. [serve] keeps the
switch, since it belongs to the connection; see [pushing]. *)
| Some "push" ->
ok [ (match Wire.field req "on" with
(* Not [:push], which marks a frame as a push. *)
| Some { Form.v = Form.Sym "nil"; _ } | None -> ":pushing nil"
| Some _ -> ":pushing t") ]
| Some "close" -> ok []
| Some op -> error ("unknown op: " ^ op)
| None -> error "no :op"
@ -4325,6 +4489,160 @@ let reply_of_exn e =
error ~loc:(Loc.to_string l) (message_of_exn e)
| _ -> error (message_of_exn e)
(* ── Pushing to the editor ─────────────────────────────────────────── *)
(* A connection that has sent [(:op "push" :on t)] is also written to without
asking: the program's output as it is printed, and the watch table while
this connection has it armed. Every other frame on the socket answers a
request, so a push is marked [:push] with its kind — ["output"] or
["watch"] — and a client reads it apart from the reply it is waiting for.
Opt-in, because a client that has not said it reads unsolicited frames
would take the first one as the answer to its next request. The raw-socket
tests and any other client keep one reply per request and nothing else.
Output is coalesced: the first bytes after a quiet spell wait [push_settle]
for more, and no two output pushes are closer than [push_gap]. A program
printing every frame is then twenty frames a second on the socket rather
than sixty or two hundred, and a single line still lands within [push_gap].
A push never interleaves with a reply. The loop is one thread: while a
request is handled nothing is pushed, what the program prints meanwhile
stays in [t.out], and [with_output] puts it on that request's reply and
empties the buffer, so it is not pushed again afterwards.
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 ──────────────────────────────────────────────────────── *)
(* One connection at a time. An editor is one client, evaluations are
@ -4335,7 +4653,34 @@ let reply_of_exn e =
so [close] shuts the whole thing down rather than waiting for another
connection nobody is going to make. *)
let serve t fd =
let p = { on = false; out_due = None; last_out = 0.; watch_every = None;
watch_due = 0.; 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 () =
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
| src ->
(* One of the two places the agent clock is read — see [agent_check].
@ -4366,6 +4711,9 @@ let serve t fd =
| r -> r
| exception e when not (fatal e) -> reply_of_exn e)
in
(match parsed with
| Either.Left req -> push_request p req op reply
| Either.Right _ -> ());
(* The two annotations are inside the boundary as well, and not because
they are likely to raise: [with_break] asks the program for its state
and [with_output] drains its pipe, so they touch the same things the
@ -4383,7 +4731,7 @@ let serve t fd =
here went straight past the two below and out of the accept loop,
ending the session. An editor that left before its reply arrived is a
closed connection and nothing more, which is what [false] says. *)
(match Wire.send fd annotated with
(match flush_pend ~block:true p fd; Wire.send fd annotated with
| () -> if op = Some "close" then true else go ()
| exception Unix.Unix_error _ -> false)
| exception Wire.Closed -> false
@ -4752,7 +5100,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
{ session; child = Some child; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false; died = None }
park_noted = false; died = None; dropped = 0 }
in
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
@ -5608,7 +5956,7 @@ let merged_setup () =
{ session; child = None; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false; died = None }
park_noted = false; died = None; dropped = 0 }
in
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());

239
test/test_dev.ml
View File

@ -3290,6 +3290,161 @@ let () =
(* ── Disassembly ───────────────────────────────────────────────── *)
(* A generic is compiled only as its copies, one per type it is called at,
so its own name has to be answered with those — the name the author
typed is the one the program never holds. Sent from a file that is not
the program's, which is how the report came in. Run against a daemon
of each backend, with the view each one has. *)
let generic_disassembly c ~backend ~form =
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let file = "/tmp/flan-devtest-sorts.flan" in
let eval code =
request c
(Printf.sprintf "(:op \"eval\" :code %s :file %s)" (Wire.quote code)
(Wire.quote file))
in
let ask () =
request c
(Printf.sprintf
"(:op \"disassemble\" :name \"selection-sort\" :form %S)" form)
in
let r =
eval
"(defn selection-sort [xs [$t]] ()\n {:where (ordered? $t)}\n \
(dotimes [i (length xs)]\n (let [m i]\n (dotimes [j \
(length xs)]\n (when (< (at xs j) (at xs m)) (set m j)))\n \
(swap xs i m))))"
in
if status r <> "ok" then fail "%s: sending a generic: %s" backend (said r)
else begin
let r = ask () in
if status r <> "error" then
fail "%s: a generic nothing calls was disassembled" backend
else if not (contains_sub (said r) "is generic")
|| not (contains_sub (said r) "[[$t]]")
|| not (contains_sub (said r) "evaluate a function that calls it")
then fail "%s: a generic nothing calls is refused for the wrong reason: %s"
backend (said r);
let r = request c "(:op \"defs\")" in
(match Wire.field r "defs" with
| Some { Form.v = Form.List rows; _ } ->
let row =
List.find_opt
(fun (d : Form.t) ->
match d.Form.v with
| Form.List ({ Form.v = Form.Str "selection-sort"; _ } :: _) ->
true
| _ -> false)
rows
in
(match row with
| Some { Form.v = Form.List [ _; { Form.v = Form.Str "fn"; _ };
{ Form.v = Form.Str sign; _ };
{ Form.v = Form.Str loc; _ }; _ ]; _ }
->
if sign <> "selection-sort [[$t]] ()" then
fail "%s: the generic's signature is not as written: %s" backend sign;
if loc <> file ^ ":1:7" then
fail "%s: the generic's location is not where it was sent from: %s"
backend loc
| _ -> fail "%s: defs does not list the generic by its name" backend)
| _ -> fail "%s: defs answered no list" backend);
let r =
eval
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3))))"
in
if status r <> "ok" then fail "%s: calling the generic at i32: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with one copy: %s" backend (said r)
else begin
if Wire.string_field r "name" <> Some "selection-sort-i32" then
fail "%s: the one copy is not the one shown" backend;
if Wire.string_field r "types" <> Some "$t = i32" then
fail "%s: the one copy does not say its types" backend;
if Wire.string_field r "loc" <> Some (file ^ ":1:7") then
fail "%s: the one copy does not name the file it came from: %s"
backend (Option.value ~default:"" (Wire.string_field r "loc"));
if not (contains_sub
(Option.value ~default:"" (Wire.string_field r "text"))
(if form = "ir" then "flan.selection-sort-i32" else "ret"))
then fail "%s: the one copy's listing is not its code" backend
end
end;
let r =
eval
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3)))\n \
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"
in
if status r <> "ok" then fail "%s: calling the generic at f64: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with two copies: %s" backend (said r)
else
match Wire.field r "copies" with
| Some { Form.v = Form.List [ a; b ]; _ } ->
let types f =
Option.value ~default:"" (Wire.string_field f "types")
in
if types a <> "$t = f64" || types b <> "$t = i32" then
fail "%s: the copies are not headed by their types: %s, %s"
backend (types a) (types b);
List.iter
(fun f ->
let name = Option.value ~default:"" (Wire.string_field f "name") in
let text = Option.value ~default:"" (Wire.string_field f "text") in
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
fail "%s: the copy %s shows some other code" backend name;
if text = "" then fail "%s: the copy %s has no listing" backend name)
[ a; b ]
| _ -> fail "%s: two copies did not come back as two" backend
end;
(* A copy made by an evaluated expression is defined only in that
expression's module, which is where its code has to be read from —
and the copies made before it are still shown beside it. *)
let r =
request c
"(:op \"eval-expr\" :code \"(selection-sort (slice [(i64 3) (i64 1)] 0 2))\")"
in
if status r <> "ok" then
fail "%s: calling the generic at i64 from an expression: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with a copy an expression made: %s" backend (said r)
else
match Wire.field r "copies" with
| Some { Form.v = Form.List [ _; _; _ ] as l; _ } ->
let l = match l with Form.List l -> l | _ -> [] in
List.iter
(fun f ->
let name = Option.value ~default:"" (Wire.string_field f "name") in
match Wire.string_field f "refused" with
| Some m -> fail "%s: the copy %s has no listing: %s" backend name m
| None ->
let text = Option.value ~default:"" (Wire.string_field f "text") in
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
fail "%s: the copy %s shows some other code" backend name;
if text = "" then fail "%s: the copy %s has no listing" backend name)
l;
(match
List.find_opt
(fun f -> Wire.string_field f "types" = Some "$t = i64") l
with
| Some f ->
(match Wire.string_field f "object" with
| Some o when String.starts_with ~prefix:"e" (Filename.basename o) -> ()
| o ->
fail "%s: the expression's copy is not read from its module: %s"
backend (Option.value ~default:"" o))
| None -> fail "%s: the expression's copy is not listed" backend)
| _ -> fail "%s: three copies did not come back as three" backend
end
end
in
(* A third daemon, over a program that keeps running, because the two
claims here are about *which* module owns a name and what the answer is
allowed to say it means — and both change the moment a body is
@ -3457,6 +3612,7 @@ let () =
"\"ir\" or";
refused "a request with no name" "(:op \"disassemble\" :form \"asm\")"
"needs :name";
generic_disassembly c ~backend:"llvm" ~form:"ir";
(* A stopped program has not thereby failed to install. The commonest way
to stop is to install a body and have it error, so the one thing the
@ -3738,6 +3894,7 @@ let () =
fail "annotate: the delivered wind's positions are not the buffer's:\n%s"
(text r)
end;
generic_disassembly c ~backend:"x86" ~form:"asm";
ignore (request c "(:op \"close\")");
Unix.close c;
if not
@ -3925,6 +4082,65 @@ let () =
fail
"the evaluation drained the program's pipe and kept none of it, so \
the output it caused is gone");
(* An editor that takes pushes and then stops reading partway through
one must not stop the program. The daemon writes pushes without
blocking, so the program keeps printing into a bounded buffer whose
oldest bytes are dropped, and a line in the output says so. Progress
is the [frames] counter, read before and after a stall long enough
that a blocked program would have filled every buffer between it and
this socket many times over. *)
let rec reply () =
let f = Wire.parse (Wire.recv c) in
if Wire.field f "push" = None then f else reply ()
in
let frames_now () =
Wire.send c
"(:op \"eval-expr\" :code \"frames\" :file \"/tmp/chatty.flan\")";
match Wire.string_field (reply ()) "value" with
| Some v -> Option.value ~default:(-1) (int_of_string_opt v)
| None -> -1
in
Wire.send c "(:op \"push\" :on t)";
ignore (reply ());
let f0 = frames_now () in
(* Into the next push's body and no further. *)
let one = Bytes.create 1 in
let rec header acc =
match Unix.read c one 0 1 with
| 1 when Bytes.get one 0 = '\n' -> int_of_string acc
| 1 -> header (acc ^ Bytes.to_string one)
| _ -> raise Wire.Closed
in
let n = header "" in
let part = Wire.read_exactly c (min 16 n) in
ignore part;
ignore (Unix.select [] [] [] 3.0);
ignore (Wire.read_exactly c (n - min 16 n));
(* Everything after the stall, until the reply to this count, is read
for the note about what was dropped. *)
Wire.send c
"(:op \"eval-expr\" :code \"frames\" :file \"/tmp/chatty.flan\")";
let noted = ref false in
let rec count () =
let f = Wire.parse (Wire.recv c) in
(match Wire.string_field f "output" with
| Some o when contains_sub o "were dropped" -> noted := true
| _ -> ());
if Wire.field f "push" = None then f else count ()
in
let f1 =
match Wire.string_field (count ()) "value" with
| Some v -> Option.value ~default:(-1) (int_of_string_opt v)
| None -> -1
in
if f0 < 0 || f1 < 0 then fail "the frame counter could not be read"
else if f1 - f0 < 400 then
fail "an editor that stopped reading mid-push held the program to %d \
frames in 3s" (f1 - f0);
if not !noted then
fail "output dropped while the editor was not reading was not reported";
Wire.send c "(:op \"push\" :on nil)";
ignore (reply ());
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
if not
@ -4295,6 +4511,29 @@ let () =
| Some v -> v <> first
| None -> false))
then fail "the watch table stopped moving";
(* Pushed, on a connection that asked for pushes: the table arrives
with nothing sent for it, marked as a push so a client can tell it
from a reply. *)
if Wire.string_field (ask "(:op \"push\" :on t)") "status" <> Some "ok"
then fail "push was refused";
Wire.send wc "(:op \"watch-enable\" :on t :interval 0.05)";
let rec reply () =
let f = Wire.parse (Wire.recv wc) in
if Wire.field f "push" = None then f else reply ()
in
if Wire.string_field (reply ()) "status" <> Some "ok" then
fail "watch-enable with an interval was refused";
(match Unix.select [ wc ] [] [] 5.0 with
| [], _, _ -> fail "no watch push arrived after arming"
| _ ->
let f = Wire.parse (Wire.recv wc) in
if Wire.string_field f "push" <> Some "watch" then
fail "the first frame after arming was not a watch push";
(match Wire.field f "watch" with
| Some { Form.v = Form.List (_ :: _); _ } -> ()
| _ -> fail "a watch push carried no table"));
Wire.send wc "(:op \"push\" :on nil)";
ignore (reply ());
(* And off again. The value already in a slot stays — nothing clears
it — but the program stops writing, so it stops changing. *)
if status (ask "(:op \"watch-enable\" :on nil)") <> "ok" then

63
test/test_flan.ml
View File

@ -2446,6 +2446,69 @@ let () =
reach past anything. Four claims: the call is refused, the refusal says
what to write instead, the name binds in every position, and a defn under
it earns no shadowing warning. *)
(* ── Operators spelled as other languages spell them ─────────────── *)
rejects_check "not= names !="
"(defn f [a i32 b i32] bool (not= a b))"
~needle:"there is no not=. Not-equal is !=. Write (!= a b)";
accepts "and the call it writes compiles"
"(defn f [a i32 b i32] bool (!= a b))";
rejects_check "not= over calls says which name to change"
"(defn f [a i32 b i32] bool (not= (+ a 1) b))"
~needle:"Write != in its place";
rejects_check "/= is not a package call"
"(defn f [a i32 b i32] bool (/= a b))" ~needle:"Write (!= a b)";
rejects_check "=/= is not a package call"
"(defn f [a i32 b i32] bool (=/= a b))" ~needle:"Write (!= a b)";
rejects_check "== names ="
"(defn f [a i32 b i32] bool (== a b))" ~needle:"Write (= a b)";
rejects_check "&& names and"
"(defn f [a bool b bool] bool (&& a b))" ~needle:"Write (and a b)";
accepts "and that call compiles" "(defn f [a bool b bool] bool (and a b))";
rejects_check "|| names or"
"(defn f [a bool b bool] bool (|| a b))" ~needle:"Write (or a b)";
rejects_check "! names not"
"(defn f [a bool] bool (! a))" ~needle:"Write (not a)";
rejects_check "a ! at an arity not does not take gets not's shape"
"(defn f [a bool b bool] bool (! a b))" ~needle:"called as (not x)";
rejects_check "a bare && is written back as the and that compiles"
"(defn f [] bool (&&))" ~needle:"Write (and)";
accepts "and it does" "(defn f [] bool (and))";
accepts "a program's own not= is its own"
"(defn not= [a i32 b i32] bool (!= a b)) \
(defn f [a i32 b i32] bool (not= a b))";
(* ── A defn with no return type ───────────────────────────────────
The body's first form lands in the return slot and parses as a type
application; the refusal names the missing return type rather than the
form's head. *)
rejects_check "a body form in the return slot is a missing return type"
"(defn f [s string] (dotimes [i (length s)] (println i)))"
~needle:"f has no return type: (dotimes ...) stands where the return type goes";
rejects_check "and says how a function returning nothing is written"
"(defn f [a i32 b i32] (+ a b))"
~needle:"a function that returns nothing writes () there";
accepts "the fix compiles"
"(defn f [s string] () (dotimes [i (length s)] (println i)))";
accepts "a type application in the slot is still a type"
"(defn f [] (Option i32) None)";
rejects_check "a misspelled constructor is a near miss"
"(defn f [] (Optoin i32) None)" ~needle:"unknown type Optoin — did you mean Option?";
rejects_check "a lowercase vec is Vec"
"(defn f [] (vec i32) (vec-new i32))" ~needle:"unknown type vec — did you mean Vec?";
rejects_check "a lowercase ptr is Ptr"
"(defn f [p (Ptr i32)] (ptr i32) p)" ~needle:"unknown type ptr — did you mean Ptr?";
rejects_check "a lowercase option is Option"
"(defn f [] (option i32) None)" ~needle:"unknown type option — did you mean Option?";
rejects_check "a lowercase map is Map"
"(defn f [] (map i32 i32) (map-new i32 i32))"
~needle:"unknown type map — did you mean Map?";
rejects_check "a map over values in the slot is a body form"
"(defn f [inc i32 xs i32] (map inc xs))" ~needle:"f has no return type";
rejects_check "an unknown capitalised head keeps the generics sentence"
"(defn f [] (Pair i32) 0)" ~needle:"Pair takes no type arguments";
rejects_check "a misspelled plain return type is still an unknown type"
"(defn f [] i3 0)" ~needle:"unknown type i3";
rejects_check "len is not a builtin"
"(defn f [s [i32]] i32 (len s))" ~needle:"there is no len";
rejects_check "and the refusal writes the call out"