JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/emacs/test-flan-dev.el
Joseph Ferano cb757868b4 Keep the printed struct a colon; it is a wire format Emacs reads back 
render.ml's output is parsed by emacs/flan-inspect.el, which hard-codes
the colon when it reads a field out of a rendered struct. Moving the
printer on its own would break inspection in the dev loop without
breaking a test that says so, so the printer waits and moves with its
reader, in the Emacs lane.

The sweep could not tell a rendered *expectation* from a Flan *source*
snippet -- both are strings in a test -- so it converted both. The suite
named every one it got wrong, and those are back.

emacs/test-flan-dev.el:415 is the one edit inside emacs/: Flan source sent
to the daemon for eval, which the parser now refuses in the old spelling.
One label, in a fixture.
2026-09-12 14:55:47 +07:00

754 lines
40 KiB
EmacsLisp
Raw Blame History

;;; test-flan-dev.el --- Drive the client against a running program -*- lexical-binding: t; -*-
;; Run as: emacs -Q --batch -L emacs -l emacs/test-flan-dev.el -- <socket> <flan-file>
;;
;; This is the client half of test_dev.ml. The OCaml test proves the daemon
;; answers correctly; this proves the elisp actually talks to it — the framing,
;; the reply reader, and C-c C-c picking the right form out of a buffer. A
;; protocol bug that only shows up under Emacs' coding systems would pass the
;; OCaml test and fail here, which is the whole reason it exists.
;;; Code:
(require 'flan-mode)
(require 'flan-dev)
(require 'flan-repl)
(defvar test-flan--failures 0)
(defmacro test-flan--said (&rest body)
"Run BODY and return the last thing it put in the echo area.
`current-message' is nil under --batch, so the echo area is watched where it
is written instead — the real `message' call the real command makes."
`(let* ((said nil)
(probe (lambda (fmt &rest args)
(when fmt (setq said (apply #'format fmt args))))))
(advice-add 'message :before probe)
(unwind-protect (progn ,@body)
(advice-remove 'message probe))
said))
(defun test-flan--check (name ok)
(if ok (message " ok %s" name)
(setq test-flan--failures (1+ test-flan--failures))
(message " FAIL %s" name)))
(let* ((args (cdr (member "--" command-line-args)))
(socket (nth 0 args))
(file (nth 1 args))
(flan (nth 2 args))
;; The buffer above is a copy in a temporary directory; this is the
;; program where it actually lives, which is the one a second daemon
;; can be started on — an `import' is resolved from the importing
;; file's own directory, and a copy in /tmp has no packages above it.
(program (nth 3 args)))
(find-file file)
;; The copy comes out of a build directory, so it may arrive read-only.
;; Set the flag directly: `read-only-mode' asks about the file on disk, and
;; a question in a batch run is a hang waiting to happen.
(setq buffer-read-only nil)
(test-flan--check "flan-mode is on for a .flan file" (eq major-mode 'flan-mode))
(test-flan--check "the modeline says so before connecting"
(and (eq (flan-dev-state) 'off)
(string-match-p "off" (flan-dev-mode-line))))
(flan-connect socket)
(test-flan--check "connected" (process-live-p flan-dev--connection))
(test-flan--check "the modeline says a program is there"
(and (eq (flan-dev-state) 'live)
(string-match-p "live" (flan-dev-mode-line))))
(test-flan--check "and says nothing in a buffer that is not Flan's"
(with-temp-buffer (null (flan-dev-mode-line))))
;; Buffer-locally, so that someone who loads this and never opens a .flan
;; file is not evaluating it on every redisplay of every buffer they have.
(test-flan--check "the indicator is in this buffer's modeline"
(member '(:eval (flan-dev-mode-line)) mode-line-misc-info))
(test-flan--check "and not in everyone else's"
(with-temp-buffer
(not (member '(:eval (flan-dev-mode-line))
mode-line-misc-info))))
;; A daemon restarted while Emacs was not looking is the ordinary case. The
;; socket outlives this connection, so dropping the process and asking again
;; is the same situation the client meets after a restart, and it must come
;; back rather than fail.
(delete-process flan-dev--connection)
(test-flan--check "a dead connection reads as lost, not as never-connected"
(and (eq (flan-dev-state) 'lost)
(string-match-p "lost" (flan-dev-mode-line))))
(let ((r (flan-dev--request '(:op "describe"))))
(test-flan--check "the next request reconnects on its own"
(and (process-live-p flan-dev--connection)
(member "step" (plist-get r :fns)))))
;; ...and knows the program's names again. An empty cache after a reconnect
;; is honest but silent: eldoc goes quiet and M-. falls through to another
;; backend, with nothing said about why.
(test-flan--check "and knows the program's names again"
(assoc "step" flan-dev--defs))
;; But a socket nobody is listening on is refused by name, rather than
;; retried forever or reported as some other failure.
(let ((flan-dev--connection nil)
(flan-dev--socket "/nonexistent/flan-dev-not-here.sock")
(raised nil))
(condition-case err (flan-dev--request '(:op "describe"))
(error (setq raised (error-message-string err))))
(test-flan--check "a socket that is gone is refused by name"
(and raised
(string-match-p "flan-dev-not-here.sock" raised)
(string-match-p "nothing is listening" raised))))
(let ((r (flan-dev--request '(:op "describe"))))
(test-flan--check "describe lists the program's functions"
(member "step" (plist-get r :fns)))
(test-flan--check "describe lists the program's globals"
(member "ticks" (plist-get r :globals))))
;; `layout' against the real daemon, through `flan-cnr-layout', which is how
;; the conditions buffer gets it. The reply is the first one with a list of
;; lists in it, so `read' on this side is doing something it does nowhere
;; else — and the daemon answers it without asking the program anything.
(require 'flan-cnr)
(let ((flan-cnr-request-function #'flan-dev--request))
(test-flan--check "a struct's fields come back named and typed"
(equal (flan-cnr-layout "Missing") '(("id" "i32" nil))))
(test-flan--check "and a type the daemon cannot place is nil, not an error"
(null (flan-cnr-layout "Nonesuch"))))
;; C-c C-c on the form at point: put point inside `step' and send it. The
;; text comes from the buffer, so this exercises `beginning-of-defun' against
;; Flan's own syntax table as much as it does the wire.
(goto-char (point-min))
(search-forward "(defn step")
(goto-char (match-beginning 0))
(save-excursion
(search-forward "(+ ticks 1)")
(replace-match "(+ ticks 41)"))
(let ((form (flan-dev--defun-at-point)))
(test-flan--check "the form at point is the defn"
(and (string-prefix-p "(defn step" (string-trim form))
(string-match-p "41" form))))
(flan-eval-defun)
;; And an error: the daemon answers with a location, the client raises.
(let ((raised nil))
(condition-case err
(flan-dev--eval "(defn step [] i64 nonsense)" "form")
(user-error (setq raised (error-message-string err))))
(test-flan--check "a form that does not check is reported"
(and raised (string-match-p "unknown name" raised))))
;; The :loc column is a *byte* offset — lib/reader.ml walks the source a byte
;; at a time — and Emacs counts characters. Same rule as the framing, a
;; different place to get it wrong, and it shows up only for someone whose
;; comments or identifiers are not ASCII.
(with-temp-buffer
(insert ";; héllo\n(defn wörld [] i64 nonsense)\n")
(let ((want (save-excursion
(goto-char (point-min))
(search-forward "nonsense")
(match-beginning 0)))
(eol (save-excursion (goto-char (point-min)) (line-end-position))))
(test-flan--check "a byte column lands on the right character"
(= (flan-dev--position
2 (1+ (string-bytes "(defn wörld [] i64 ")))
want))
(test-flan--check "a column past the end of a line is clamped to it"
(= (flan-dev--position 1 500) eol))))
;; A rejected form is marked where it is, not only in the echo area. The
;; daemon numbers lines from the start of what it was sent, so a form taken
;; from the middle of a buffer only lands on the right line because the
;; client pads it back into place before sending.
(goto-char (point-min))
(search-forward "(defn step")
(goto-char (match-beginning 0))
(let ((defn-line (line-number-at-pos)))
(save-excursion
(search-forward "(+ ticks 41)")
(replace-match "(+ ticks nonsense)"))
(ignore-errors (flan-eval-defun))
(let ((ovs (seq-filter (lambda (o) (overlay-get o 'flan-dev-error))
(overlays-in (point-min) (point-max)))))
(test-flan--check "a rejected form gets exactly one error overlay"
(= 1 (length ovs)))
(test-flan--check "the overlay is at the form, not at line 1"
(and ovs (>= (line-number-at-pos (overlay-start (car ovs)))
defn-line)))
(test-flan--check "the overlay carries the daemon's reason"
(and ovs
(string-match-p
"unknown name"
(or (overlay-get (car ovs) 'help-echo) ""))))
(test-flan--check "and shows it beside the code"
(and ovs
(string-match-p
"unknown name"
(or (overlay-get (car ovs) 'after-string) "")))))
;; ...and it goes away when the next evaluation is accepted. A marker left
;; behind after a fix is a lie about the running program. Point moved to
;; the error, which is the point of all this, so start the search over.
(goto-char (point-min))
(search-forward "(+ ticks nonsense)")
(replace-match "(+ ticks 41)")
(search-backward "(defn step")
;; A silent success is indistinguishable from a silent failure, so an
;; accepted evaluation says what landed in the running program and what it
;; cost. The name comes from the *reply*: the daemon is the one that knows
;; which names it installed.
(let ((said (test-flan--said (flan-eval-defun))))
(test-flan--check "an accepted evaluation clears it"
(null (seq-filter (lambda (o) (overlay-get o 'flan-dev-error))
(overlays-in (point-min) (point-max)))))
(test-flan--check "and says which name landed"
(and said (string-match-p "\\_<step\\_>" said)))
(test-flan--check "and how long it took"
(and said (string-match-p "[0-9]+ ms" said)))))
;; A declaration the program already has installs nothing, and must say so
;; rather than reporting a time for a build that did not happen.
(let ((said (test-flan--said
(flan-dev--eval "(defvar ticks i64)" "form"))))
(test-flan--check "an evaluation with nothing to install says so"
(and said (string-match-p "nothing to install" said)
(not (string-match-p "installed" said)))))
;; Many names are counted and sampled. An echo area truncated in the middle
;; of the tenth name says neither how many there were nor which.
(test-flan--check "a long list of names is counted, not cut off"
(equal (flan-dev--names-phrase
'("a" "b" "c" "d" "e" "f") "fallback")
"6 names (a, b, c, d, …)"))
(test-flan--check "a short one is just named"
(equal (flan-dev--names-phrase '("a" "b") "fallback") "a, b"))
;; `defs' is what eldoc, completion and M-. all read. One op answering all
;; three, cached, because eldoc fires on an idle timer and completion inside
;; redisplay, and neither may block on a socket.
(test-flan--check "the program's names are known"
(assoc "step" flan-dev--defs))
(test-flan--check "with a signature"
(equal (nth 2 (assoc "step" flan-dev--defs)) "step [] i64"))
(test-flan--check "a global is known, and says it is one"
(equal (nth 1 (assoc "ticks" flan-dev--defs)) "var"))
(test-flan--check "so is an imported package's extern"
(let ((d (assoc "agent/wait-raw" flan-dev--defs)))
(and d (equal (nth 1 d) "extern"))))
;; `step' was last installed from this buffer, so that is where the daemon
;; says it is — which is also the check that the client's line padding put it
;; on the line it is really on rather than on line 1.
(test-flan--check "a fn carries where it is written"
(equal (nth 3 (assoc "step" flan-dev--defs))
(format "%s:%d:7" buffer-file-name
(save-excursion
(goto-char (point-min))
(search-forward "(defn step")
(line-number-at-pos)))))
;; eldoc: the signature of the name at point, and of the form point is
;; inside, which is what you want while typing arguments.
(goto-char (point-min))
(search-forward "(set ticks (step")
(let ((said nil))
(test-flan--check "eldoc answers for the name at point"
(and (flan-dev-eldoc-function
(lambda (s &rest _) (setq said s)))
said (string-match-p "step \\[\\] i64" said))))
(let ((said nil))
(save-excursion
(goto-char (point-min))
(search-forward "(set ticks (step)")
(backward-char 1) ; inside (step ...), not on the name
(flan-dev-eldoc-function (lambda (s &rest _) (setq said s))))
(test-flan--check "and for the form point is inside"
(and said (string-match-p "step" said))))
(let ((said nil))
(with-temp-buffer
(insert "not-a-flan-name")
(flan-dev-eldoc-function (lambda (s &rest _) (setq said s))))
(test-flan--check "and says nothing about a name the program has not got"
(null said)))
;; Completion: the running program's names, through `completion-at-point'.
(goto-char (point-min))
(search-forward "(defn step")
(let* ((capf (flan-dev-completion-at-point))
(table (nth 2 capf)))
(test-flan--check "completion offers the program's own names"
(member "step" (all-completions "ste" table)))
(test-flan--check "and the names an import brought in"
(member "agent/wait" (all-completions "agent/" table)))
(test-flan--check "and annotates each with what it is"
(equal (funcall (plist-get (nthcdr 3 capf)
:annotation-function)
"ticks")
" var")))
;; M-. through xref, so it is the key it always is.
(let ((xs (xref-backend-definitions 'flan "step"))
(line (save-excursion (goto-char (point-min))
(search-forward "(defn step")
(line-number-at-pos))))
(test-flan--check "M-. finds where a function is written"
(and (= 1 (length xs))
(let ((l (xref-item-location (car xs))))
(and (file-equal-p (xref-location-group l)
buffer-file-name)
(= (xref-location-line l) line))))))
;; And the two things it cannot do, refused by name with the reason rather
;; than by opening an empty buffer.
(let ((raised nil))
(condition-case err (xref-backend-definitions 'flan "ticks")
(user-error (setq raised (error-message-string err))))
(test-flan--check "M-. on a global refuses, saying why"
(and raised (string-match-p "ticks" raised)
(string-match-p "no location" raised))))
(let ((raised nil))
(condition-case err (xref-backend-definitions 'flan "rand-seed")
(user-error (setq raised (error-message-string err))))
(test-flan--check "M-. into the prelude refuses, saying why"
(and raised (string-match-p "prelude" raised)
(string-match-p "not a file on disk" raised))))
(let ((raised nil))
(condition-case err (xref-backend-definitions 'flan "no-such-name")
(user-error (setq raised (error-message-string err))))
(test-flan--check "and so does a name the program does not have"
(and raised (string-match-p "no no-such-name" raised))))
;; A name installed now must complete now, not after the next connect.
(flan-dev--eval "(defn freshly-added [] i64 7)" "form")
(test-flan--check "a name just installed is known immediately"
(equal (nth 2 (assoc "freshly-added" flan-dev--defs))
"freshly-added [] i64"))
;; The session is not poisoned by that: a good form still lands.
(flan-dev--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form")
;; The program's own output arrives on replies and lands in its buffer, so
;; a long-running program is not writing into a terminal nobody is watching.
(flan-dev--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-dev--request '(:op "describe")))
(setq seen (with-current-buffer (get-buffer-create flan-dev-output-buffer)
(string-match-p "HELLO" (buffer-string)))))
(test-flan--check "the program's output reaches its buffer" seen))
;; The REPL buffer: typed input goes through the same eval-expr request, and
;; the value lands at the prompt while the program's own output goes to
;; *flan-output*. Conflating those two is the bug worth testing for.
(test-flan--check "an incomplete form is not sent"
(not (flan-repl--complete-p "(+ 1")))
(test-flan--check "a whole form is sent" (flan-repl--complete-p "(+ 1 2)"))
(test-flan--check "a paren in a string does not count"
(not (flan-repl--complete-p "(f \"(\"")))
(flan-repl)
(with-current-buffer flan-repl-buffer
(goto-char (point-max))
(insert "(+ 20 3)")
(flan-repl-return)
(let ((deadline (+ (float-time) 15)))
(while (and (not (string-match-p "23" (buffer-string)))
(< (float-time) deadline))
(accept-process-output nil 0.05)))
(test-flan--check "the REPL shows a value"
(string-match-p "23" (buffer-string)))
(goto-char (point-max))
(insert "no-such-thing")
(flan-repl-return)
(let ((deadline (+ (float-time) 15)))
(while (and (not (string-match-p "unknown name" (buffer-string)))
(< (float-time) deadline))
(accept-process-output nil 0.05)))
(test-flan--check "the REPL shows an error"
(string-match-p "unknown name" (buffer-string)))
;; A value and the program's output travel by different routes: the value
;; is the result of the request, the output rides along with the reply.
;; Showing them in one place would be convenient and wrong.
(goto-char (point-max))
(insert "(println \"PRINTED\")")
(flan-repl-return)
(let ((deadline (+ (float-time) 15)))
(while (and (not (with-current-buffer flan-dev-output-buffer
(string-match-p "PRINTED" (buffer-string))))
(< (float-time) deadline))
(ignore-errors (flan-dev--request '(:op "describe")))
(accept-process-output nil 0.05)))
(test-flan--check "printed text goes to the output buffer"
(with-current-buffer flan-dev-output-buffer
(string-match-p "PRINTED" (buffer-string))))
;; ...and the prompt got the *value*, which for a call made for its effect
;; is Unit. The text it printed is not the value and does not belong here.
(test-flan--check "and the prompt got the value, not the text"
(string-match-p "()" (buffer-string))))
;; ── The break loop ────────────────────────────────────────────────────
;;
;; An unhandled `error' stops the program on the frame that erred instead of
;; killing it, and this is the half of that an editor sees: it has to notice
;; without being told, say what stopped it, offer the restarts, and keep
;; working while the program sits there. Last in this file because the
;; program is left running afterwards but its `step' has been through a
;; break, and nothing above should have to reason about that.
;; Refused while it is running, by name. There is no restart stack to walk
;; from a running program, and an empty prompt would be worse than a refusal.
(let ((raised nil))
(condition-case err (flan-break)
(user-error (setq raised (error-message-string err))))
(test-flan--check "the prompt refuses while the program is running"
(and raised (string-match-p "running" raised))))
;; The poll is a real timer, registered on connect. What it *does* is
;; checked below by calling it; that it is scheduled at all is checked here,
;; because a background discovery that nothing ever runs discovers nothing.
(test-flan--check "a poll timer is running"
(and (timerp flan-dev--timer)
(eq (timer--function flan-dev--timer) #'flan-dev--poll)))
;; Break it: `step' is called every time round the program's loop, so a body
;; that errors stops it on its own game thread, in a frame of its own — not
;; inside anything this client asked for. Nothing tells Emacs.
(flan-dev--eval
"(defn step [] i64 (restart-case (do (error (Missing {.id 7})) 0) (use-placeholder [] -1)))"
"form")
(let ((deadline (+ (float-time) 20)))
(while (and (not flan-dev--stopped) (< (float-time) deadline))
(flan-dev--poll)
(accept-process-output nil 0.05)))
(test-flan--check "the client notices a stop nobody asked about"
(equal flan-dev--stopped "Missing"))
(test-flan--check "and the modeline says so, with the condition"
(and (eq (flan-dev-state) 'stopped)
(string-match-p "stopped" (flan-dev-mode-line))
(string-match-p "Missing" (flan-dev-mode-line))))
;; What the prompt would offer. `completing-read' is not driven here — a
;; minibuffer in a batch run is a hang waiting to happen — so the list it
;; reads and the two commands it dispatches to are exercised instead.
(test-flan--check "the restarts on offer are the ones the frame declared"
(equal (flan-dev-restarts) '("use-placeholder")))
;; And what it would put in front of someone. The labels carry the position,
;; because the position is what gets chosen: two frames may offer the same
;; name and only a number can say which one. A pure function over a reply,
;; so it is checked against the shapes a real daemon cannot easily be made to
;; produce as well as against the one it just did.
(test-flan--check "the prompt numbers what it offers"
(equal (flan-dev--restart-candidates '("use-placeholder") nil)
'(("0. use-placeholder" . 0))))
(test-flan--check "a shadowed name is two distinguishable choices"
(equal (mapcar #'cdr
(flan-dev--restart-candidates
'("retry" "use-placeholder" "retry") nil))
'(0 1 2)))
(test-flan--check "a restart below the break is shown, and shown as such"
(let ((table (flan-dev--restart-candidates
'("retry" "use-placeholder") '(1))))
(and (not (string-match-p "cannot be taken" (caar table)))
(string-match-p "cannot be taken" (car (nth 1 table)))
(equal (cdr (nth 1 table)) 1))))
;; The payoff. The break loop *is* the poll loop, so an expression sent now
;; runs on the stopped thread and comes back — which is the one moment
;; anybody actually wants C-x C-e to work.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 20 3)")
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "C-x C-e works while the program is stopped"
(and said (string-match-p "23" said))))
(delete-region beg (point-max)))
;; And installing, which the break loop allows on purpose: there is no frame
;; in progress, so the rule against swapping a body that is on the stack does
;; not apply. This is the fix-it-and-retry loop — the broken `step' is
;; replaced here, and the resume below returns into the old one for the last
;; time before every later call reaches the new body through its cell.
(let ((said (test-flan--said
(flan-dev--eval "(defn step [] i64 (set ticks (+ ticks 1)) ticks)"
"form"))))
(test-flan--check "a fix installs while the program is stopped"
(and said (string-match-p "\\_<step\\_>" said))))
;; Choosing one. "ok" from the daemon means accepted — the stopped thread
;; takes it on its next pass — so the client stops claiming a break and lets
;; the next poll settle it.
;; By position, which is the path `C-c C-b' takes: the name goes with it as
;; the receipt the program checks, not as the lookup.
(flan-dev-restart-at 0 "use-placeholder")
(let ((deadline (+ (float-time) 20)))
(while (and (not (eq (flan-dev-state) 'live)) (< (float-time) deadline))
(flan-dev--poll)
(accept-process-output nil 0.05)))
(test-flan--check "choosing a restart resumes the program"
(and (null flan-dev--stopped)
(eq (flan-dev-state) 'live)))
;; ...and the client is an ordinary client again on the far side of it.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 1 1)")
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "and everything works again afterwards"
(and said (string-match-p "2" said))))
(delete-region beg (point-max)))
;; ── The documentation buffer ──────────────────────────────────────────
;;
;; The same four facts `defs' carries, in a buffer: eldoc answers while you
;; are typing, and a signature in the echo area is gone the moment you do
;; anything else. Run before the disconnect below, because it reads the
;; running program.
(flan-doc "step")
(with-current-buffer flan-doc-buffer
(let ((text (buffer-string)))
(test-flan--check "the doc buffer names the thing and its signature"
(and (string-match-p "\\`step" text)
(string-match-p "step \\[\\] i64" text)))
(test-flan--check "and says what kind of thing it is"
(string-match-p "Kind +fn" text))
))
;; Where it is written, for a name that has not been re-installed from a
;; buffer since the daemon built it: `main' is still at the location the
;; daemon read it from, which is the ordinary case and the one with a
;; button on it.
(flan-doc "main")
(with-current-buffer flan-doc-buffer
(test-flan--check "and where a definition is written"
(string-match-p
(regexp-quote (file-name-nondirectory program))
(buffer-string))))
;; A global has no Loc in the Tast, so the buffer says that in the same words
;; M-. refuses in — rather than leaving the line out, which reads as though
;; the name had no home at all.
(flan-doc "ticks")
(with-current-buffer flan-doc-buffer
(test-flan--check "a global says why there is no location"
(string-match-p "no location for a var" (buffer-string))))
(let ((raised nil))
(condition-case err (flan-doc "no-such-name")
(user-error (setq raised (error-message-string err))))
(test-flan--check "and a name the program has not got is refused"
(and raised (string-match-p "no no-such-name" raised))))
(flan-disconnect)
(test-flan--check "disconnected" (not (process-live-p flan-dev--connection)))
(test-flan--check "and the poll timer is cancelled with it"
(null flan-dev--timer))
;; ── Starting the daemon from Emacs ────────────────────────────────────
;;
;; Last, and after the disconnect above, because it runs a *second* daemon:
;; nothing before this should have to reason about which of two programs a
;; request went to. Its own socket for the same reason — and because
;; `flan dev' with no -s puts one beside the program, which for a test
;; program in /tmp is a path shared with every other thing running there.
(setq flan-dev-command flan)
(let ((socket2 (concat socket "-started-from-emacs")))
(ignore-errors (delete-file socket2))
(test-flan--check "nothing to quit before anything was started"
(let ((raised nil))
(condition-case err (flan-dev-quit)
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "no daemon started" raised))))
(flan-dev program socket2)
(test-flan--check "M-x flan-dev builds, launches and connects"
(and (process-live-p flan-dev--daemon)
(eq (flan-dev-state) 'live)))
(test-flan--check "and it is the program that was asked for"
(member "step" (plist-get (flan-dev--request '(:op "describe"))
:fns)))
;; Refused rather than silently restarted: a second daemon would take the
;; first one's program and everything in its memory with it.
(test-flan--check "a second one is refused while the first is alive"
(let ((raised nil))
(condition-case err (flan-dev program socket2)
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "already running" raised))))
;; The daemon owns the program's lifetime, so quitting has to actually end
;; the process — not just drop the socket and leave it running.
;; Restarting the program: for a change the running one cannot take — a
;; struct whose layout moved — where the answer is a new build, a new
;; process and the session that compiled it. Proved by what it throws
;; away: a name installed into the old program is not in the new one.
(flan-dev--eval "(defn only-in-the-old-program [] i64 1)" "form")
(test-flan--check "a name installed into the running program is there"
(assoc "only-in-the-old-program" flan-dev--defs))
(let ((old flan-dev--daemon))
(flan-dev-restart-program)
(test-flan--check "restarting gives a different daemon, connected"
(and (not (process-live-p old))
(process-live-p flan-dev--daemon)
(not (eq old flan-dev--daemon))
(eq (flan-dev-state) 'live))))
(test-flan--check "and a program built from source, without the addition"
(and (assoc "step" flan-dev--defs)
(null (assoc "only-in-the-old-program"
flan-dev--defs))))
(let ((proc flan-dev--daemon))
(flan-dev-quit)
;; The process, not the variable: forgetting a daemon is not stopping
;; one, and a program left running with nothing attached to it is
;; exactly what the terminal loop used to leave behind.
(test-flan--check "quitting ends the daemon"
(and (not (process-live-p proc))
(null flan-dev--daemon)
(not (process-live-p flan-dev--connection))
(eq (flan-dev-state) 'off)))
;; The daemon unlinks its socket on the way out, so this is the same
;; claim seen from the other side.
(test-flan--check "and takes its socket with it"
(not (file-exists-p socket2))))
(ignore-errors (delete-file socket2)))
;; A program that does not exist is refused here rather than by a daemon
;; that starts, fails to build and exits — which looks the same from a
;; distance and takes a compile to find out.
(test-flan--check "a file that is not there is refused before anything starts"
(let ((raised nil))
(condition-case err (flan-dev "/nonexistent/nope.flan")
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "no such file" raised))))
;; ── Navigating a file ─────────────────────────────────────────────────
;;
;; No daemon in any of this: imenu and which-function read the buffer, which
;; is the point — they work on a file nobody has run yet, and they keep
;; working when the program is stopped or gone.
(with-temp-buffer
(insert ";;;; A file with one of everything.\n"
"(defstruct Missing [id i32])\n"
"(defvar ticks i64)\n"
"(defconst limit i64 10)\n"
"(declare later [] i64)\n"
"(defn step [] i64\n"
" (let [x 1]\n"
" (defn not-top-level [] i64 2)\n"
" (+ ticks x)))\n")
(flan-mode)
(let* ((index (imenu--make-index-alist))
(group (lambda (name) (cdr (assoc name index)))))
(test-flan--check "imenu finds a function, where it is written"
(equal (marker-position
(cdr (assoc "step" (funcall group "Functions"))))
(save-excursion (goto-char (point-min))
(search-forward "(defn step")
(match-beginning 0))))
(test-flan--check "and a struct, under its own heading"
(assoc "Missing" (funcall group "Types")))
(test-flan--check "and both kinds of global"
(and (assoc "ticks" (funcall group "Variables"))
(assoc "limit" (funcall group "Variables"))))
;; A forward declaration is not a definition; listing it beside one
;; would show the same name twice with nothing to tell them apart.
(test-flan--check "and a declaration, said to be one"
(and (assoc "later" (funcall group "Declared"))
(null (assoc "later" (funcall group "Functions")))))
;; A `defn' inside a `let' defines nothing at the top level, and the
;; index is anchored at column 0 so that it cannot offer one.
(test-flan--check "and nothing that is not a top-level form"
(null (assoc "not-top-level" (funcall group "Functions")))))
;; which-function: the case is a long body scrolled past its own header.
(goto-char (point-min))
(search-forward "(+ ticks x)")
(test-flan--check "which-function names the definition point is in"
(equal (flan-current-defun-name) "step"))
(goto-char (point-min))
(test-flan--check "and says nothing above the first one"
(null (flan-current-defun-name))))
;; ── A rejection lasts as long as the action it was about ──────────────
;;
;; The overlay is feedback on the evaluation that just failed, so the next
;; command in that buffer takes it down. What is checked here is the
;; mechanism and not Emacs' command loop: `execute-kbd-macro' under --batch
;; runs no `pre-command-hook' at all (and does not even move point), so there
;; is no way from here to make the real loop run one. `run-hooks' is what
;; the loop calls, and calling it is the closest honest thing — it proves the
;; hook is installed, in the right buffer and nowhere else, and that running
;; it clears the overlay and uninstalls itself. It does not prove Emacs runs
;; it, which is Emacs' own contract.
(let ((buf (flan-dev--buffer-visiting file)))
(with-current-buffer buf
(flan-dev-clear-errors)
(let ((marked (flan-dev--show-error (format "%s:2:1" file) "no such name")))
(test-flan--check "a rejection is marked in the buffer it came from"
(and marked (flan-dev--error-overlays)))
(test-flan--check "and the buffer is armed to take it down again"
(memq #'flan-dev--clear-errors-on-command
pre-command-hook))
;; Buffer-local, or every buffer in the session runs this on every
;; keystroke for the sake of a buffer that had one bad evaluation.
(test-flan--check "and nobody else is"
(not (memq #'flan-dev--clear-errors-on-command
(default-value 'pre-command-hook))))
(run-hooks 'pre-command-hook)
(test-flan--check "the next command in that buffer clears it"
(null (flan-dev--error-overlays)))
(test-flan--check "and the hook goes with the last overlay"
(not (memq #'flan-dev--clear-errors-on-command
pre-command-hook))))))
;; ── Disassembly ───────────────────────────────────────────────────────
;;
;; Its own daemon, because the first one was disconnected above and a
;; disassembly is a question only a live session can answer: the daemon is
;; the thing that built the module and still has the .ll and the .so.
(let ((socket3 (concat socket "-disasm")))
(ignore-errors (delete-file socket3))
(flan-dev program socket3)
(test-flan--check "a daemon to disassemble against"
(process-live-p flan-dev--connection))
(when (executable-find "objdump")
(flan-disassemble "step")
(with-current-buffer flan-disassembly-buffer
(let ((text (buffer-string)))
(test-flan--check "C-c C-a writes a disassembly of the name"
(string-match-p "\\`; disassembly for step" text))
;; The header is the half a listing cannot carry: what the answer
;; claims, which for generated code is never "this is running".
(test-flan--check "with the daemon's own account of what it shows"
(string-match-p "showing" text))
(test-flan--check "and instructions under it, numbered from zero"
(string-match-p "^ 0000 " text)))))
;; The other half of the same question, on the same body.
(flan-disassemble "step" t)
(with-current-buffer flan-disassembly-buffer
(let ((text (buffer-string)))
(test-flan--check "C-u C-c C-a writes the IR it was built from"
(and (string-match-p "\\`; LLVM IR for step" text)
(string-match-p "^define .*flan\\.step" text)))
;; Nothing has been evaluated into this daemon, so the body in the
;; cell is still the one the process was launched with — the one case
;; where what is installed *now* is knowable, and it says so.
(test-flan--check "and says the program is still running the host's copy"
(string-match-p "host executable" text))))
;; Refused by name rather than shown as an empty buffer.
(test-flan--check "a name the program does not define is refused by name"
(let ((raised nil))
(condition-case err (flan-disassemble "no-such-thing")
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "no function named" raised))))
(test-flan--check "and so is a global, which has no code to show"
(let ((raised nil))
(condition-case err (flan-disassemble "ticks")
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "not a function" raised))))
(flan-dev-quit)
(ignore-errors (delete-file socket3)))
(if (zerop test-flan--failures)
(message "flan-dev.el: all tests passed")
(message "\n%d failure(s)" test-flan--failures)
(kill-emacs 1)))
;;; test-flan-dev.el ends here
Reference in New Issue View Git Blame Copy Permalink