Joseph Ferano
0c9f043bb1
The snapshot made the listing stand still; it did not make the handoff safe. A choice is validated against the snapshot on top when the request lands and resolved against the snapshot on top when the game thread next looks, and between those the loop runs evaluations — one that errors pushes a break of its own, whose loop reaches the flag first and takes its own index 2 for the one somebody picked off the outer list. That is the failure this change exists to end, arriving by a different door. So each snapshot carries a generation, a choice carries the generation it was validated against, and a loop claims only what is addressed to it. A mismatch is left set rather than dropped: the listener already answered ok, so the break it was meant for must still be able to take it. Depth could not do this — an outer break resuming and a new one starting reuses the number. The snapshot is also popped before the depth comes down now, so the two never describe different breaks. The client's own new path gets tested too: the candidate table is pure, so the shapes a real daemon will not easily produce are checked directly, and the break-and-resume test now goes through restart-at rather than by name. flan-dev-unreachable-restarts was dead on arrival — flan-break reads :unreachable off its own reply — and is gone.
743 lines
40 KiB
EmacsLisp
743 lines
40 KiB
EmacsLisp
;;; 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))))
|
|
|
|
;; 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 "print-line")
|
|
(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 (print-line \"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 "(print-line \"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
|