JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/emacs/test-flan.el

1967 lines
106 KiB
EmacsLisp
Raw Blame History

;;; test-flan.el --- Drive the client against a running program -*- lexical-binding: t; -*-
;; Run as: emacs -Q --batch -L emacs -l emacs/test-flan.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)
(require 'flan-repl)
(require 'flan-watch)
(require 'flan-lower)
(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--result ()
"The text of the inline result overlay in this buffer, or nil.
An expression's value now goes beside the form rather than into the echo
area, so this is where the assertions that used to read `test-flan--said'
read instead. Overlays exist under --batch — the error-overlay checks below
already rely on it — so nothing here is a stand-in for the real thing."
(let ((ovs (flan--result-overlays)))
(and (= 1 (length ovs))
(substring-no-properties
(or (overlay-get (car ovs) 'after-string) "")))))
(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-state) 'off)
(string-match-p "off" (flan-mode-line))))
(flan-connect socket)
(test-flan--check "connected" (process-live-p flan--connection))
(test-flan--check "the modeline says a program is there"
(and (eq (flan-state) 'live)
(string-match-p "live" (flan-mode-line))))
(test-flan--check "and says nothing in a buffer that is not Flan's"
(with-temp-buffer (null (flan-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-mode-line)) mode-line-misc-info))
(test-flan--check "and not in everyone else's"
(with-temp-buffer
(not (member '(:eval (flan-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--connection)
(test-flan--check "a dead connection reads as lost, not as never-connected"
(and (eq (flan-state) 'lost)
(string-match-p "lost" (flan-mode-line))))
(let ((r (flan--request '(:op "describe"))))
(test-flan--check "the next request reconnects on its own"
(and (process-live-p flan--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--defs))
;; But a socket nobody is listening on is refused by name, rather than
;; retried forever or reported as some other failure.
(let ((flan--connection nil)
(flan--socket "/nonexistent/flan-not-here.sock")
(raised nil))
(condition-case err (flan--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-not-here.sock" raised)
(string-match-p "nothing is listening" raised))))
;; ── The two frames a real daemon does not send ────────────────────────
;;
;; Both of these are what the client does when the other end is wrong, and
;; neither can be asked of a daemon that is working: a stand-in process
;; stands where one would be, with its frames written into its buffer by
;; hand. A live process rather than a dead one on purpose — which of the
;; two silences the reader reports depends on whether the far end is still
;; there, and this is the branch a person actually meets.
;;
;; What is under test is the state the connection is left in. A truncated
;; frame used to raise `wrong-type-argument' out of `byte-to-position' and
;; leave its header in the buffer, so every later request read the frame
;; before its own, for ever; an unreadable payload used to be read before it
;; was deleted, so it was never consumed and the *same* bytes signalled
;; again on every request after it. Both were permanent, and both are meant
;; to cost one request now.
(let* ((buf (generate-new-buffer " *flan-stand-in*"))
;; `cat' with nothing on its input: a process that is alive, has a
;; buffer, and will never say anything of its own.
(stand-in (start-process "flan-stand-in" buf "cat")))
(set-process-query-on-exit-flag stand-in nil)
;; Unibyte, as `flan--open' makes it: the framing counts bytes, and
;; `position-bytes' on a multibyte buffer counts something else.
(with-current-buffer buf (set-buffer-multibyte nil))
(unwind-protect
(let ((flan-reply-timeout 0.3))
;; Announced 40 bytes, wrote 12, went quiet.
(with-current-buffer buf (insert "40\n(:status \"o"))
(let ((raised nil))
(condition-case err (flan--read-reply stand-in)
(error (setq raised (error-message-string err))))
(test-flan--check "a body that stalls is a timeout, said in words"
(and raised (string-match-p "no reply in" raised)))
(test-flan--check "and the half-frame is dropped rather than left to be read as the next reply"
(zerop (buffer-size buf))))
;; A payload that will not read, with a good frame behind it: the
;; claim is that the second one arrives, which is the whole of
;; self-healing and stronger than an empty buffer.
;; Two frames, written one after the other because that is what
;; they are: three bytes of `(:a', which will not read, and then a
;; whole reply behind it.
(with-current-buffer buf
(insert "3\n(:a")
(insert "14\n(:status \"ok\")"))
(let ((raised nil))
(condition-case err (flan--take-reply stand-in)
(error (setq raised (error-message-string err))))
(test-flan--check "a payload that will not read signals"
raised)
(test-flan--check "and is consumed, so the reply behind it arrives"
(equal (flan--take-reply stand-in)
'(:status "ok")))))
(delete-process stand-in)
(kill-buffer buf)))
(let ((r (flan--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))))
;; The third state. A program that finishes no longer ends its process: the
;; main thread parks holding every global, and `flan-rerun' sends it round
;; `main' again. The client has to be able to *say* that, because from
;; anywhere else in Emacs a finished program and a running one look the same.
;;
;; Driven through `flan--absorb' with a made-up reply rather than by
;; waiting for this program to finish. What is under test is the client's
;; reading of `:parked', which is a decision it makes about a plist; making
;; the real program park first would put the daemon, the agent and a
;; condition variable between the question and the answer, and test_dev.ml
;; already does that end to end.
(let ((said (test-flan--said
(flan--absorb '(:status "ok" :stopped nil :parked t)))))
(test-flan--check "a reply that says parked makes the client say so"
(and (eq (flan-state) 'parked)
(string-match-p "parked" (flan-mode-line))))
;; Once, on the edge, and naming the way out: the poll runs every second
;; and the whole point of the message is that it is read.
(test-flan--check "and says how to get the program back, once"
(and said (string-match-p "runs it again" said)
(null (test-flan--said
(flan--absorb
'(:status "ok" :stopped nil :parked t)))))))
;; Stopped is not parked and must win where both arrive: a break has
;; restarts to choose and is the state with something to answer in it.
(flan--absorb '(:status "ok" :stopped t :condition "Missing" :parked t))
(test-flan--check "a stopped program reads as stopped even while parked is set"
(eq (flan-state) 'stopped))
(flan--absorb '(:status "ok" :stopped nil :parked nil))
(test-flan--check "and both clear again"
(eq (flan-state) 'live))
;; `flan-describe' had two words for three states, and "exited" was the
;; wrong one of them: nothing exited, and being told so is what sent people
;; to `flan-restart-program' for a thing `flan-rerun' does without
;; losing the build.
(test-flan--check
"flan-describe names the parked state rather than calling it exited"
(let ((said (test-flan--said
(cl-letf (((symbol-function 'flan--request)
(lambda (&rest _)
'(:status "ok" :fns ("step") :globals ("ticks")
:alive t :parked t))))
(flan-describe)))))
(and said (string-match-p "parked" said))))
;; And the refusal a parked program gives an op it cannot answer, which is
;; the daemon's words reaching a person: it has to name the state and the
;; command, not say the program exited.
(test-flan--check
"a parked refusal reaches the user with the way out in it"
(let ((raised nil))
(cl-letf (((symbol-function 'flan--request)
(lambda (&rest _)
'(:status "error"
:message "a backtrace is the frames of a stopped program, and a parked one has no frames at all; the program has finished and its process is parked — M-x flan-rerun starts it again"))))
(condition-case err (flan-rerun)
(error (setq raised (error-message-string err)))))
(and raised (string-match-p "parked" raised)
(string-match-p "flan-rerun" raised))))
;; `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--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--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--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--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--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-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-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--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--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--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--defs))
(test-flan--check "with a signature"
(equal (nth 2 (assoc "step" flan--defs)) "step [] i64"))
(test-flan--check "a global is known, and says it is one"
(equal (nth 1 (assoc "ticks" flan--defs)) "var"))
(test-flan--check "so is an imported package's extern"
(let ((d (assoc "agent/wait-raw" flan--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--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-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-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-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-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--eval "(defn freshly-added [] i64 7)" "form")
(test-flan--check "a name just installed is known immediately"
(equal (nth 2 (assoc "freshly-added" flan--defs))
"freshly-added [] i64"))
;; The session is not poisoned by that: a good form still lands.
(flan--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--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-output-buffer)
(string-match-p "HELLO" (buffer-string)))))
(test-flan--check "the program's output reaches its buffer" seen))
;; ── Which evaluator C-x C-e reaches ──────────────────────────────────
;;
;; The dispatch is off the form that would be *sent*, so these four are
;; checked with point where the key would be pressed rather than by handing
;; the predicate a string: a form's depth is a fact about the buffer, and an
;; off-by-one at the open delimiter would make every form read as nested,
;; leave the feature switched permanently off, and still pass a test that
;; only looked at the head. No daemon round trip here — nothing is sent —
;; which is why all four are affordable.
(goto-char (point-min))
(search-forward "(defvar ticks i64)")
(test-flan--check "a top-level defvar takes the declaration path"
(equal (car (flan--declaration-before-point)) "defvar"))
(goto-char (point-min))
(search-forward " ticks)")
(test-flan--check "and so does a top-level defn"
(equal (car (flan--declaration-before-point)) "defn"))
;; The case the whole "form, not cursor" rule exists for: this line is
;; inside `step', so the enclosing declaration is a `defn' — and evaluating
;; here must still mean this expression, not a reinstall of the function.
(goto-char (point-min))
(search-forward "(+ ticks 41)")
(test-flan--check "an expression inside a defn body does not"
(null (flan--declaration-before-point)))
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 2 3)")
(test-flan--check "nor does a bare expression at top level"
(null (flan--declaration-before-point)))
;; ...and it still evaluates as one, which is the half of this key that
;; was already working and must not have moved. The value is now drawn
;; beside the form and no longer echoed, so both halves are asserted: an
;; overlay that says it, and an echo area that does not say it twice.
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "which C-x C-e evaluates and shows beside the form"
(let ((r (test-flan--result)))
(and r (string-match-p "5" r)
(string-match-p "=>" r))))
(test-flan--check "and does not also say it in the echo area"
(not (and said (string-match-p "=>" said))))
;; The overlay is anchored to the form that produced it, not to point
;; and not to the start of the line: two expressions one under the
;; other both returning 2 is the case the echo area cannot answer.
(test-flan--check "the value is drawn at the end of the form"
(let ((ovs (flan--result-overlays)))
(and (= 1 (length ovs))
(= (overlay-start (car ovs)) (point-max)))))
;; It lasts exactly as long as the evaluation it is about. The hook is
;; buffer-local and installed only while there is something to remove,
;; the way the error overlays' is.
(test-flan--check "and a command in the buffer takes it away"
(progn
(test-flan--check
"with a hook installed while it is up"
(memq #'flan--clear-result-on-command
(buffer-local-value 'pre-command-hook
(current-buffer))))
(flan--clear-result-on-command)
(and (null (flan--result-overlays))
(not (memq #'flan--clear-result-on-command
(buffer-local-value
'pre-command-hook
(current-buffer))))))))
(delete-region beg (point-max)))
;; Switched off, the echo area is what is left: the two settings are not two
;; spellings of one thing, and a value has to come out somewhere.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 7 8)")
(let* ((flan-inline-result nil)
(said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "with the overlay off the value goes back to the echo area"
(and said (string-match-p "15" said)
(string-match-p "=>" said)
(null (flan--result-overlays)))))
(delete-region beg (point-max)))
;; ── C-c C-c on what is not a declaration ─────────────────────────────
;;
;; The complaint this routing came from: `(+ 1 1)' written at the top level
;; of a buffer, `C-M-x' pressed, and the parser's "is a top-level
;; declaration, not an expression" coming back — because the key only ever
;; had the one path. `C-M-x' and `C-c C-c' are one command and both route.
(goto-char (point-max))
(let ((beg (point)))
;; The trailing newline is the point, not tidiness: `end-of-defun' steps
;; over it, so the bounds it hands back end at the start of the next line
;; and a value drawn at that position appears in column 0 below the form.
;; Without the newline here the bug is invisible.
(insert "\n(+ 1 1)\n")
;; Point *inside* the form, which is where `C-c C-c' is pressed from and
;; the difference between this and `C-x C-e': the form is the one point is
;; in, not the one behind it.
(search-backward "1 1")
(test-flan--check "C-M-x on a bare top-level expression evaluates it"
(progn (flan-eval-defun)
(let ((r (test-flan--result)))
(and r (string-match-p "=> 2" r)))))
(test-flan--check "and draws the value after the closing paren"
(let ((ovs (flan--result-overlays)))
(and (= 1 (length ovs))
(= (char-before (overlay-start (car ovs))) ?\))
(= (line-number-at-pos (overlay-start (car ovs)))
(line-number-at-pos
(save-excursion
(goto-char (point-min))
(search-forward "(+ 1 1)")))))))
;; What a keystroke would do. There are no commands under --batch, so the
;; `pre-command-hook' that takes a value down never runs and the next
;; check below would be reading this one's overlay.
(flan-clear-result)
(goto-char (point-max))
(delete-region beg (point-max)))
;; And the other half, which is the one that must not have moved: point in
;; the middle of a `defn' body still reinstalls the enclosing declaration.
;; `flan--defun-bounds' takes the form point is *inside* and
;; `flan--declaration-before-point' the one *before* point, and routing
;; C-c C-c off the second would have turned this into C-x C-e.
(goto-char (point-min))
(search-forward "(+ ticks 41)")
(test-flan--check "the head is asked of the form point is inside"
(equal (flan--declaration-head-at
(car (flan--defun-bounds)))
"defn"))
(let ((said (test-flan--said (flan-eval-defun))))
(test-flan--check "C-c C-c from inside a defn body still installs it"
(and said (string-match-p "\\_<step\\_>" said)
(string-match-p "installed" said)))
(test-flan--check "and draws no value beside it"
(null (flan--result-overlays))))
;; `package' is the one head the two keys disagree about, and it is a real
;; disagreement rather than an oversight: `Parse.expr' has no arm refusing
;; it, so C-x C-e's "would this fail as an expression" says no, while
;; `Parse.decl' has one and C-c C-c has always installed it. Routing both
;; off one list would have quietly taken that away. Nothing is sent here —
;; the claim is only about which path each key picks.
(with-temp-buffer
(flan-mode)
(insert "(package demo)\n")
(goto-char (point-min))
(search-forward "demo")
(test-flan--check "C-c C-c treats a package form as a declaration"
(equal (flan--declaration-head-at
(car (flan--defun-bounds)) flan--defun-heads)
"package"))
(goto-char (point-max))
(test-flan--check "and C-x C-e does not, for the reason it never has"
(null (flan--declaration-before-point))))
;; A prefix on the expression path is a flag and not a position — there is
;; no inside for one to point at — so both `C-u' and `C-u C-u' mean the one
;; thing, which is `C-u C-x C-e's behaviour reached through the other key.
;;
;; Checked by reading the request rather than by sending it: `:pause t' on a
;; thunk parks the program in the break loop, and doing that here would hand
;; every test below this line a stopped daemon. What the daemon then does
;; with the flag is test_dev.ml's question anyway; this one is only whether
;; the client sends a flag where it cannot send a position.
(goto-char (point-max))
(let ((beg (point))
(sent nil))
(insert "\n(+ 3 4)")
(search-backward "3 4")
(let ((probe (lambda (req) (setq sent req) '(:status "ok" :value "7"))))
(advice-add 'flan--request :override probe)
(unwind-protect
(progn
(flan-eval-defun '(4))
(test-flan--check "C-u C-M-x on an expression sends the flag"
(and (equal (plist-get sent :op) "eval-expr")
(eq (plist-get sent :pause) t)))
(flan-eval-defun '(16))
(test-flan--check "and C-u C-u means the same, having nowhere else to point"
(eq (plist-get sent :pause) t))
(flan-eval-defun)
(test-flan--check "and no prefix sends no flag at all"
(null (plist-member sent :pause))))
(advice-remove 'flan--request probe)))
(test-flan--check "none of which leaves a pause mark behind"
(null (flan--pause-overlays)))
(flan-clear-result)
(goto-char (point-max))
(delete-region beg (point-max)))
;; A refusal must never be drawn as a value. This is the collision the two
;; overlays could have had: one command, one form, and both paths wanting
;; the end of the same line.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 1 nonsense)")
(search-backward "nonsense")
(ignore-errors (flan-eval-defun))
(test-flan--check "a refused expression gets no value overlay"
(null (flan--result-overlays)))
(test-flan--check "and is marked as an error instead"
(let ((ovs (flan--error-overlays)))
(and (= 1 (length ovs))
(string-match-p
"unknown name"
(or (overlay-get (car ovs) 'help-echo) "")))))
;; The padding argument, which is why the expression path sends
;; `flan--text-at': the daemon numbers from the start of what it was sent,
;; so an unpadded snippet puts this overlay on line 1 of the file. The
;; column is the half `flan--text' alone would not have fixed, so the
;; check is the token and not the line — a client that padded lines only
;; would pass "not line 1" and still point at the open paren.
(test-flan--check "and marked at the word it is about, not at line 1"
(let ((ovs (flan--error-overlays)))
(and ovs (save-excursion
(goto-char (overlay-start (car ovs)))
(looking-at-p "nonsense")))))
(flan-clear-errors)
(goto-char (point-max))
(delete-region beg (point-max)))
;; A declaration can be written where it is prose and not a declaration, and
;; the depth at its open delimiter says nothing about that: a form at column
;; 1 inside a comment or a string is at depth 0 like any other, so the head
;; was the only thing being asked and a sentence would have been compiled.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n;; (defvar commented i64 1)\n\"(defvar inside i64 1)\"")
;; Point after the form's own closing paren rather than at the end of the
;; line: `backward-sexp' walks over a whole comment, so from the end of
;; one it never reaches the paren inside it and the guard is never asked.
(goto-char beg)
(search-forward "commented i64 1)")
(test-flan--check "a declaration written in a comment is not one"
(null (flan--declaration-before-point)))
(goto-char beg)
(search-forward "inside i64 1)")
(test-flan--check "and neither is one written in a string"
(null (flan--declaration-before-point)))
(delete-region beg (point-max)))
;; And the top of the buffer, where there is nothing behind point at all.
;; `backward-sexp' does not signal there — it stays where it is — so the
;; form the predicate looked at was the one *after* point and the region it
;; measured out was empty: C-x C-e at point-min sent the first declaration
;; in the file by name with no body at all, and the daemon installed it.
;; Nothing is sent now, from either path, and the refusal says why.
(goto-char (point-min))
(test-flan--check "the form after point is not the form before it"
(null (flan--declaration-before-point)))
(test-flan--check "and C-x C-e at the top of a buffer refuses rather than sending nothing"
(let ((raised nil))
(condition-case err (flan-eval-last-sexp)
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "no form before point" raised))))
;; The bug this key had: a `defvar' typed at the top of a file could only be
;; evaluated with C-c C-c, because C-x C-e sent it to the expression
;; evaluator and the parser refused it as a declaration. One round trip, on
;; the form the report has to be able to name.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(defvar spark i64 9)")
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "C-x C-e on a top-level defvar installs it"
(and said (string-match-p "\\_<spark\\_>" said)
(string-match-p "installed" said)))
;; The two paths share a key now, so the echo area is the only thing
;; left that says which of them ran. An installed declaration reports
;; what changed; an expression reports `=>' and a value.
(test-flan--check "and says so rather than printing a value"
(and said (not (string-match-p "=>" said)))))
(delete-region beg (point-max)))
;; And the literal complaint, on the `defvar' actually written in the file
;; rather than on one typed in for the occasion. What is asserted is only
;; what the client decides: the var is named and no value is printed.
;; Whether the daemon answers "installed" or "nothing to install" is its
;; call and depends on what this session has been through by now, and a test
;; that pinned one of them here would be testing the order of the checks
;; above it. A defvar declares no functions either way, which is what makes
;; the name — and not the kind of form — the subject of the sentence.
(goto-char (point-min))
(search-forward "(defvar ticks i64)")
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "C-x C-e on the file's own defvar reports the var"
(and said (string-match-p "\\_<ticks\\_>" said)
(not (string-match-p "=>" said)))))
;; 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))
;; Propertized, as interactive input always is — font-lock marks what a
;; batch `insert' would leave bare. comint hands the sender the text
;; properties and all, and a propertized string prints as #(...), which
;; the daemon's reader takes as a symbol and a stray list rather than a
;; string. So this line is the regression test for `flan--bare'.
(insert (propertize "(+ 20 3)" 'fontified t 'face 'default))
(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-output-buffer
(string-match-p "PRINTED" (buffer-string))))
(< (float-time) deadline))
(ignore-errors (flan--request '(:op "describe")))
(accept-process-output nil 0.05)))
(test-flan--check "printed text goes to the output buffer"
(with-current-buffer flan-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--timer)
(eq (timer--function flan--timer) #'flan--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--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--stopped) (< (float-time) deadline))
(flan--poll)
(accept-process-output nil 0.05)))
(test-flan--check "the client notices a stop nobody asked about"
(equal flan--stopped "Missing"))
(test-flan--check "and the modeline says so, with the condition"
(and (eq (flan-state) 'stopped)
(string-match-p "stopped" (flan-mode-line))
(string-match-p "Missing" (flan-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-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--restart-candidates '("use-placeholder") nil)
'(("0. use-placeholder" . 0))))
(test-flan--check "a shadowed name is two distinguishable choices"
(equal (mapcar #'cdr
(flan--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--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)")
(flan-eval-last-sexp)
(test-flan--check "C-x C-e works while the program is stopped"
(let ((r (test-flan--result)))
(and r (string-match-p "23" r))))
(flan-clear-result)
(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--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-restart-at 0 "use-placeholder")
(let ((deadline (+ (float-time) 20)))
(while (and (not (eq (flan-state) 'live)) (< (float-time) deadline))
(flan--poll)
(accept-process-output nil 0.05)))
(test-flan--check "choosing a restart resumes the program"
(and (null flan--stopped)
(eq (flan-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)")
(flan-eval-last-sexp)
(test-flan--check "and everything works again afterwards"
(let ((r (test-flan--result)))
(and r (string-match-p "2" r))))
(flan-clear-result)
(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))))
;; A builtin, which is the case this buffer used to refuse outright: the name
;; is fine and the program's symbol table has never heard of it, so C-c C-v
;; answered "the running program defines no arena-new" about a name that
;; works. `arena-new' by name because it is the one that was reported.
(flan-doc "arena-new")
(with-current-buffer flan-doc-buffer
(let ((text (buffer-string)))
(test-flan--check "C-c C-v on a builtin answers"
(string-match-p "\\`arena-new" text))
(test-flan--check "with its signature"
(string-match-p "arena-new \\[i64\\] Allocator" text))
(test-flan--check "and says it is a builtin"
(string-match-p "Kind +builtin" text))
;; The honest answer to "where", and not the one an empty location would
;; otherwise have produced: a global's location is missing, a builtin's
;; never existed.
(test-flan--check "and that it lives in the compiler, not in a file"
(string-match-p "Defined +in the compiler" text))
(test-flan--check "and carries a line about what it does"
(string-match-p "capacity is explicit" text))))
;; The other half of the table: a name written as a name rather than as a
;; call, which `var' answers and which reads here as a builtin too.
(flan-doc "context/allocator")
(with-current-buffer flan-doc-buffer
(test-flan--check "and so does a builtin that is a name, not a call"
(string-match-p "Kind +builtin" (buffer-string))))
;; M-. has nowhere to jump either way, but the reason is the point: the
;; refusal names the compiler instead of reporting a gap in the daemon.
(let ((raised nil))
(condition-case err (xref-backend-definitions 'flan "arena-new")
(user-error (setq raised (error-message-string err))))
(test-flan--check "M-. on a builtin says it is in the compiler"
(and raised (string-match-p "arena-new" raised)
(string-match-p "compiler" raised))))
(test-flan--check "eldoc has a builtin's signature too"
(let ((said nil))
(with-temp-buffer
(insert "arena-new")
(flan-eldoc-function
(lambda (s &rest _) (setq said s))))
(and said (string-match-p "arena-new \\[i64\\]" said)
;; The kind rides along, as it does for a global,
;; so the echo area says which of the two this is.
(string-match-p "builtin" said))))
(let* ((capf (with-temp-buffer
(insert "arena")
(flan-completion-at-point)))
(table (nth 2 capf)))
(test-flan--check "completion offers builtins"
(member "arena-new" (all-completions "arena-" table)))
;; They are appended after the program's own names rather than merged in,
;; so a table built from this order does not bury what is being worked on.
(test-flan--check "and still offers the program's names first"
(< (seq-position table "step")
(seq-position table "arena-new"))))
;; ── The watch buffer ──────────────────────────────────────────────────
;;
;; 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"
(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)
(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.
;;
;; 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))
(goto-char (point-min))
(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)))
;; 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.
(with-current-buffer flan-watch-buffer
(goto-char (point-max))
(let ((where (point)))
(flan-watch--tick)
(flan-watch--tick)
(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)))
(kill-buffer flan-watch-buffer)
(flan-disconnect)
(test-flan--check "disconnected" (not (process-live-p flan--connection)))
(test-flan--check "and the poll timer is cancelled with it"
(null flan--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-command flan)
;; `flan-daemon-args' reaches the command line. Checked against the
;; argument list rather than by starting a daemon with a flag on it: the
;; claim is that the setting is spliced in at all, which a build of the
;; whole program would take seconds to say and say no more clearly. The
;; daemon buffer's first line is checked too, because it is a second
;; spelling of the same command and somebody reads it to find out what ran.
(let ((seen nil)
(probe nil))
(setq probe (lambda (&rest args) (setq seen (plist-get args :command)) nil))
(advice-add 'make-process :override probe)
(unwind-protect
(let ((flan-daemon-args '("--llvm" "--debug")))
(flan--start-daemon program "/tmp/does-not-matter.sock")
(test-flan--check "flan-daemon-args reaches the daemon's command line"
(equal seen (list flan "dev" program
"--llvm" "--debug"
"-s" "/tmp/does-not-matter.sock")))
(test-flan--check "and the daemon buffer shows the command that ran"
(with-current-buffer flan-daemon-buffer
(string-match-p
"--llvm --debug"
(buffer-substring-no-properties
(point-min) (point-max)))))
(setq seen nil)
(let ((flan-daemon-args nil))
(flan--start-daemon program "/tmp/does-not-matter.sock"))
(test-flan--check "and an empty setting leaves the old command line"
(equal seen (list flan "dev" program
"-s" "/tmp/does-not-matter.sock"))))
(advice-remove 'make-process probe)))
(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-quit)
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "no daemon started" raised))))
(flan program socket2)
(test-flan--check "M-x flan builds, launches and connects"
(and (process-live-p flan--daemon)
(eq (flan-state) 'live)))
(test-flan--check "and it is the program that was asked for"
(member "step" (plist-get (flan--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 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--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--defs))
(let ((old flan--daemon))
(flan-restart-program)
(test-flan--check "restarting gives a different daemon, connected"
(and (not (process-live-p old))
(process-live-p flan--daemon)
(not (eq old flan--daemon))
(eq (flan-state) 'live))))
(test-flan--check "and a program built from source, without the addition"
(and (assoc "step" flan--defs)
(null (assoc "only-in-the-old-program"
flan--defs))))
(let ((proc flan--daemon))
(flan-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--daemon)
(not (process-live-p flan--connection))
(eq (flan-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)))
;; ── One command, one session ──────────────────────────────────────────
;;
;; Attaching to a second program while a daemon of this Emacs' own is
;; running is an ordinary thing to do — the other one is in a terminal, and
;; `flan-connect' is the command for it — and it used to cost the first
;; program its life: `flan-quit' sent `close' down whichever connection
;; was current and then killed the daemon, which by then were two different
;; programs. Both halves are checked here.
;;
;; Stand-ins rather than two real daemons. Nothing about this is a claim
;; about the wire: what is under test is which process each command reaches
;; for, and a `cat' is a live process with a buffer, which is all either of
;; them looks at. `cat' also parrots whatever is written to it, so the
;; `close' a disconnect sends comes straight back as its own reply and
;; nothing waits. Every variable touched is bound, so the suite carries on
;; with the state it had.
(let* ((mine-buf (generate-new-buffer " *flan-mine*"))
(theirs-buf (generate-new-buffer " *flan-theirs*"))
(mine (start-process "flan-mine" mine-buf "cat"))
(theirs (start-process "flan-theirs" theirs-buf "cat")))
(set-process-query-on-exit-flag mine nil)
(set-process-query-on-exit-flag theirs nil)
(with-current-buffer theirs-buf (set-buffer-multibyte nil))
(unwind-protect
(let ((flan--daemon mine)
(flan--daemon-socket "/tmp/flan-emacs-mine.sock")
(flan--file "/tmp/flan-emacs-mine.flan")
(flan--connection theirs)
(flan--socket "/tmp/flan-emacs-theirs.sock")
(flan--defs nil))
(test-flan--check
"flan-connect elsewhere names both programs rather than dropping one"
(let ((raised nil))
(condition-case err (flan-connect "/tmp/flan-emacs-elsewhere.sock")
(user-error (setq raised (error-message-string err))))
(and raised
(string-match-p "flan-emacs-mine" raised)
(string-match-p "flan-emacs-elsewhere" raised))))
(test-flan--check "and the connection it refused to replace is untouched"
(eq flan--connection theirs))
;; And the command whose name promises one program. It closes the
;; connection it is on and leaves the daemon alone, saying so —
;; where it used to end both.
(let ((said (test-flan--said (flan-quit))))
(test-flan--check "quit ends the session it is connected to"
(not (process-live-p theirs)))
(test-flan--check "and leaves the daemon this Emacs started running"
(process-live-p mine))
(test-flan--check "and says which one it left"
(and said (string-match-p "still running" said)
(string-match-p "flan-emacs-mine" said)))))
(ignore-errors (delete-process mine))
(ignore-errors (delete-process theirs))
(kill-buffer mine-buf)
(kill-buffer theirs-buf)))
;; 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 "/nonexistent/nope.flan")
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "no such file" raised))))
;; ── Which file M-x flan starts ────────────────────────────────────────
;;
;; The `interactive' form by itself, evaluated the way the command loop
;; evaluates it. Calling the command would build and launch a program, and
;; none of that is in question here: the question is only which file the
;; form arrives at, and whether it had to ask to get there.
(let* ((asked nil)
(answer "/nonexistent/answered.flan")
(probe (lambda (&rest _) (setq asked t) answer))
(spec (cadr (interactive-form 'flan))))
(advice-add 'read-file-name :override probe)
(unwind-protect
(progn
(with-temp-buffer
(setq buffer-file-name "/nonexistent/here.flan")
(setq asked nil)
(test-flan--check "a .flan buffer is started without a prompt"
(and (equal (eval spec t) '("/nonexistent/here.flan"))
(not asked))))
(with-temp-buffer
(setq buffer-file-name "/nonexistent/notes.org")
(setq asked nil)
(test-flan--check "a buffer that is not Flan's is asked about"
(and (equal (eval spec t) (list answer)) asked)))
(with-temp-buffer
(setq asked nil)
(test-flan--check "and so is one visiting no file at all"
(and (equal (eval spec t) (list answer)) asked)))
;; The escape hatch, for starting some other program from a .flan
;; buffer — the one case the silent path would otherwise close off.
(with-temp-buffer
(setq buffer-file-name "/nonexistent/here.flan")
(setq asked nil)
(let ((current-prefix-arg '(4)))
(test-flan--check "a prefix argument asks from a .flan buffer too"
(and (equal (eval spec t) (list answer)) asked)))))
(advice-remove 'read-file-name probe)))
;; The old name is gone rather than deprecated, so nothing should still
;; answer to it — an alias left behind is what keeps a rename from finishing.
(test-flan--check "the -dev- names are not defined any more"
(not (or (fboundp 'flan-dev) (fboundp 'flan-dev-quit)
(boundp 'flan-dev-socket-name))))
;; ── 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--buffer-visiting file)))
(with-current-buffer buf
(flan-clear-errors)
(let ((marked (flan--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--error-overlays)))
(test-flan--check "and the buffer is armed to take it down again"
(memq #'flan--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--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--error-overlays)))
(test-flan--check "and the hook goes with the last overlay"
(not (memq #'flan--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.
;;
;; And an LLVM one, asked for through the setting rather than around it:
;; `C-u C-c C-a' shows the IR a body was built from and an x86 session has
;; none, so half of what this section checks only exists on that backend.
;; Going through `flan-daemon-args' means the same run proves the setting
;; reaches a daemon that actually starts, which the stubbed check above
;; deliberately does not.
(let ((socket3 (concat socket "-disasm"))
(flan-daemon-args '("--llvm")))
(ignore-errors (delete-file socket3))
(flan program socket3)
(test-flan--check "a daemon to disassemble against"
(process-live-p flan--connection))
(test-flan--check "and flan-daemon-args put --llvm on its command line"
(member "--llvm" (process-command flan--daemon)))
(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-quit)
(ignore-errors (delete-file socket3)))
;; ── Every lowering of one function, in one buffer ─────────────────────
;;
;; No daemon: this command compiles the file rather than asking the running
;; program, which is the whole distinction between it and `C-c C-a' above.
;;
;; Most of what is checked here is the renderer -- folding, and the memory
;; of what was folded -- so the fetch is replaced with canned text. Driving
;; it through the real one would put four compilers and an `llc -O2' behind
;; every redraw, and prove nothing about folding that the canned text does
;; not. The real fetch is exercised once, at the end, where it belongs.
;;
;; `buffer-string' is no use for any of it: it returns hidden text too, so
;; "all four are still named when everything is shut" would pass without
;; 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.
(let* ((flan-lower--state (copy-alist flan-lower--state))
(flan-lower-fetch-function
(lambda (section _file name _flags)
(format "%s-first-line of %s\n%s-second-line\n"
section name section)))
(visible
(lambda ()
(let ((out nil) (p (point-min)))
(while (< p (point-max))
(if (invisible-p p)
(setq p (next-single-char-property-change p 'invisible))
(push (buffer-substring-no-properties p (1+ p)) out)
(setq p (1+ p))))
(apply #'concat (nreverse out)))))
;; Somewhere inside a section's body, which is where invisibility is
;; the thing to ask about.
(body-of
(lambda (id)
(with-current-buffer flan-lower-buffer
(save-excursion
(goto-char (point-min))
(search-forward (format "%s-first-line" id))
(point))))))
(flan-lowering "step" file)
(with-current-buffer flan-lower-buffer
(test-flan--check "C-c C-l opens a lowering buffer in its own mode"
(derived-mode-p 'flan-lower-mode))
(test-flan--check "TAB is the lowering buffer's toggle, not Outline's"
(eq (key-binding (kbd "TAB")) #'flan-lower-toggle))
;; The claim the header makes, which is the opposite of the one
;; `flan-disassemble' makes, and the reason both commands exist.
(test-flan--check "whose header says it is the file and not the program"
(string-match-p "what this file compiles to"
(buffer-string)))
(test-flan--check "and names all four lowerings"
(let ((v (funcall visible)))
(and (string-match-p "LLVM IR" v)
(string-match-p "LLVM -O0" v)
(string-match-p "LLVM -O2" v)
(string-match-p "x86 backend" v))))
(test-flan--check "with a line count beside each, so a shut one still says something"
(= 4 (length (seq-filter
(lambda (l) (string-match-p " 2 lines\\'" l))
(split-string (funcall visible) "\n")))))
;; Out of the box the IR is the open one, so it is the one whose body
;; can be read and the other three are the ones that cannot.
(test-flan--check "the open section's body is showing"
(not (invisible-p (funcall body-of 'ir))))
(test-flan--check "and a shut section's body is not"
(and (invisible-p (funcall body-of 'O0))
(invisible-p (funcall body-of 'O2))
(invisible-p (funcall body-of 'x86))))
;; TAB, on the heading and from inside the body, which are the two
;; places a reader's point actually is.
(flan-lower--goto-section 'x86)
(flan-lower-toggle)
(test-flan--check "TAB on a heading opens that section"
(not (invisible-p (funcall body-of 'x86))))
(test-flan--check "and leaves the others alone"
(and (not (invisible-p (funcall body-of 'ir)))
(invisible-p (funcall body-of 'O0))))
(goto-char (funcall body-of 'x86))
(flan-lower-toggle)
(test-flan--check "TAB inside a body shuts the section it is in"
(invisible-p (funcall body-of 'x86)))
(test-flan--check "and puts point back on its heading, not into hidden text"
(eq (flan-lower--section-at-point) 'x86))
;; `c' and `e': the buffer as a summary, and the buffer as everything.
(flan-lower-collapse-all)
(test-flan--check "c shuts every section"
(seq-every-p (lambda (s)
(invisible-p (funcall body-of (car s))))
flan-lower--sections))
(test-flan--check "and all four are still named, which is what makes it a summary"
(let ((v (funcall visible)))
(and (string-match-p "LLVM IR" v)
(string-match-p "LLVM -O0" v)
(string-match-p "LLVM -O2" v)
(string-match-p "x86 backend" v)
;; ...and not one line of any listing.
(not (string-match-p "first-line" v)))))
(flan-lower-expand-all)
(test-flan--check "e opens every section"
(seq-every-p (lambda (s)
(not (invisible-p (funcall body-of (car s)))))
flan-lower--sections))
;; n and p move between headings, the way they do in the inspector.
(goto-char (point-min))
(outline-next-visible-heading 1)
(test-flan--check "n moves to the first heading"
(eq (flan-lower--section-at-point) 'ir))
(outline-next-visible-heading 2)
(outline-previous-visible-heading 1)
(test-flan--check "n n p leaves point on the second"
(eq (flan-lower--section-at-point) 'O0)))
;; The point of the whole thing: the backend open and nothing else, then
;; the command run again on a *different* function. Keyed to the section
;; rather than to the function, so the preference survives the change of
;; subject -- which is the case that would fail if it were keyed the other
;; way, and the one the author asked for by name.
(flan-lower-collapse-all)
(with-current-buffer flan-lower-buffer
(flan-lower--goto-section 'x86)
(flan-lower-toggle))
(flan-lowering "main" file)
(with-current-buffer flan-lower-buffer
(test-flan--check "re-running names the new function"
(string-match-p "; every lowering of main" (buffer-string)))
(test-flan--check "and the section that was open is still the open one"
(not (invisible-p (funcall body-of 'x86))))
(test-flan--check "and the ones that were shut are still shut"
(and (invisible-p (funcall body-of 'ir))
(invisible-p (funcall body-of 'O0))
(invisible-p (funcall body-of 'O2))))
(test-flan--check "the new function's text is what is in there"
(string-match-p "x86-first-line of main" (buffer-string)))
;; A refresh is a redraw of the same thing, and must not throw the
;; reader back to the top of a listing they were part-way down.
(flan-lower-expand-all)
(goto-char (funcall body-of 'O2))
(forward-line 1)
;; The line's *text* as well as its coordinates: point is put back by
;; heading plus a line count, so comparing only the coordinates would
;; check that the two halves are inverses of each other rather than that
;; the reader is looking at what they were looking at.
(let ((was (flan-lower--position))
(line (buffer-substring-no-properties
(line-beginning-position) (line-end-position))))
(flan-lower-refresh)
(test-flan--check "g redraws without moving point off the line it was on"
(and (equal was (flan-lower--position))
(equal line (buffer-substring-no-properties
(line-beginning-position)
(line-end-position))))))
;; And from the header, where there is no section to come back to: the
;; top, which is where it was, rather than wherever the redraw ended.
(goto-char (point-min))
(flan-lower-refresh)
(test-flan--check "and from the header it comes back to the top, not the end"
(= (point) (point-min)))))
;; And once for real, against the compiler dune just built: four
;; subprocesses, four narrowings, and the one thing canned text cannot
;; check -- that the awk `dump.sh' does by hand finds the same function in
;; four formats that agree about nothing else.
(if (not (and flan (file-executable-p flan)
(executable-find "llc") (executable-find "as")
(executable-find "objdump")))
(message " skip lowering: no llc/as/objdump, or no compiler to run")
(let ((flan-lower-program flan)
;; A copy, because a toggle `setf's into this and a quoted literal
;; is a constant.
(flan-lower--state (copy-alist '((ir . t) (O0 . t) (O2 . t) (x86 . t)))))
(flan-lowering "step" program)
(with-current-buffer flan-lower-buffer
(let ((text (buffer-string)))
(test-flan--check "the IR section is the definition and nothing above it"
(string-match-p "^define .*flan\\.step" text))
(test-flan--check "the -O0 and -O2 sections are that label's own block"
(= 2 (length (seq-filter
(lambda (l) (string-match-p "\\`flan\\.step:" l))
(split-string text "\n")))))
(test-flan--check "and -O2 is the shorter of the two, which is the point"
(< (length (alist-get 'O2 flan-lower--texts))
(length (alist-get 'O0 flan-lower--texts))))
(test-flan--check "the x86 section is the backend's bytes, disassembled"
(and (string-match-p "<flan\\.step>:" text)
(string-match-p "push +%rbp" text))))
;; `r' is the other half of the caching claim: one section redrawn,
;; and the IR every section is downstream of left where it was. The
;; mtime is the only evidence of that, since a re-emitted out.ll would
;; have the same contents as the one it replaced.
(let ((mtime (file-attribute-modification-time
(file-attributes
(expand-file-name "out.ll" flan-lower--dir))))
(before (alist-get 'O2 flan-lower--texts)))
(flan-lower--goto-section 'O2)
(flan-lower-refresh-section)
(test-flan--check "r redraws one section without re-emitting the IR it reads"
(equal mtime (file-attribute-modification-time
(file-attributes
(expand-file-name "out.ll"
flan-lower--dir)))))
(test-flan--check "and the section it redrew says the same thing it did"
(equal before (alist-get 'O2 flan-lower--texts)))
(test-flan--check "and the other three are still there"
(and (alist-get 'ir flan-lower--texts)
(alist-get 'O0 flan-lower--texts)
(alist-get 'x86 flan-lower--texts))))
;; The scratch directory is this buffer's and goes with it; /tmp is
;; not a place to leave four intermediates behind per invocation.
(let ((dir flan-lower--dir))
(kill-buffer)
(test-flan--check "and the intermediates go when the buffer does"
(not (file-directory-p dir)))))))
;; ── Marking a form with (pause) ───────────────────────────────────────
;;
;; docs/DISCUSS.md §9: `C-u' before an evaluation marks a form so the program
;; stops when it runs, and the buffer is never edited — the position goes on
;; the wire beside the code and the daemon splices the call in after parsing.
;;
;; Last in this file on purpose: the one live check here *stops the program*,
;; and everything above it needs one that is running.
;;
;; Three things are the client's own and need no daemon at all: which form a
;; prefix argument picks, the byte column that names it, and the fact that a
;; mark outlives the next command where a rejection does not.
(with-temp-buffer
(flan-mode)
(insert "(defvar ticks i64)\n\n(defn step [] i64\n (set ticks (+ ticks 1))\n ticks)\n")
(goto-char (point-min))
(search-forward "(+ ticks 1)")
(goto-char (1- (match-end 0))) ; inside the (+ ...), before its ")"
(let* ((b (flan--defun-bounds))
(inner (flan--pause-bounds b '(4)))
(whole (flan--pause-bounds b '(16))))
(test-flan--check "no prefix marks nothing"
(null (flan--pause-bounds b nil)))
(test-flan--check "C-u marks the form point is inside"
(equal (buffer-substring-no-properties
(car inner) (cdr inner))
"(+ ticks 1)"))
;; A `defn' is a declaration and cannot be wrapped in a `do', so the
;; daemon reads the top-level form's own position as "stop on entry".
(test-flan--check "C-u C-u marks the top-level form itself"
(equal whole b)))
;; Point at the very start of the defn is not nested inside anything, and
;; `backward-up-list' would either fail or walk somewhere surprising. It
;; falls back to the defun, which is the only honest answer.
(goto-char (point-min))
(search-forward "(defn step")
(goto-char (match-beginning 0))
(let ((b (flan--defun-bounds)))
(test-flan--check "and a prefix with point not nested falls back to it"
(equal (flan--pause-bounds b '(4)) b)))
;; The column is a byte offset, because the reader walks the source a byte
;; at a time. Same rule as the `:loc' column, the other way round — and
;; `flan--position' is the inverse, so a round trip is the check.
(goto-char (point-min))
(search-forward "(+ ticks 1)")
(let* ((pos (match-beginning 0))
(lc (flan--wire-position pos)))
(test-flan--check "a marked position round-trips through the wire"
(= (flan--position (nth 0 lc) (nth 1 lc)) pos)))
(with-temp-buffer
(insert ";; héllo\n(defn wörld [] i64 (+ 1 1))\n")
(goto-char (point-min))
(search-forward "(+ 1 1)")
(test-flan--check "and counts bytes, not characters, past a non-ASCII one"
(equal (flan--wire-position (match-beginning 0))
(list 2 (1+ (string-bytes "(defn wörld [] i64 ")))))))
;; A mark is an annotation on the running program and not feedback about one
;; command, so unlike a rejection it has to survive the next keystroke. That
;; difference is the whole of its lifetime, and it is checked here the same
;; way the rejection's is: by calling what the command loop calls.
(with-temp-buffer
(flan-mode)
(insert "(defn step [] i64 (+ 1 1))\n")
(goto-char (point-min))
(search-forward "(+ 1 1)")
(flan--show-pause (match-beginning 0) (match-end 0))
(test-flan--check "a mark is drawn over the form"
(= 1 (length (flan--pause-overlays))))
(run-hooks 'pre-command-hook)
(test-flan--check "and survives the next command, where a rejection would not"
(= 1 (length (flan--pause-overlays))))
;; Re-marking the same form leaves one, not two stacked overlays whose
;; faces compound into something that is not the face.
(flan--show-pause (match-beginning 0) (match-end 0))
(test-flan--check "and marking it again leaves one mark, not two"
(= 1 (length (flan--pause-overlays))))
(flan-clear-pause)
(test-flan--check "and clearing takes it down"
(null (flan--pause-overlays))))
;; And once against a real daemon: the round trip, the overlay drawn off the
;; reply's `:pause' rather than off what was asked for, and the mark coming
;; down again when the same form is evaluated plainly.
(let ((socket4 (concat socket "-pause")))
(ignore-errors (delete-file socket4))
(flan program socket4)
(test-flan--check "a daemon to mark a form in"
(process-live-p flan--connection))
(with-temp-buffer
(flan-mode)
(insert "(defn step [] i64\n (set ticks (+ ticks 1))\n ticks)\n")
(goto-char (point-min))
(search-forward "(+ ticks 1)")
(goto-char (1- (match-end 0)))
(flan-eval-defun '(4))
(let ((ovs (flan--pause-overlays)))
(test-flan--check "C-u C-c C-c marks the form point is inside"
(and (= 1 (length ovs))
(equal (buffer-substring-no-properties
(overlay-start (car ovs))
(overlay-end (car ovs)))
"(+ ticks 1)")))
(test-flan--check "and marks it as a pause, not as an error"
(and ovs
(eq (overlay-get (car ovs) 'face)
'flan-pause-face))))
;; The program calls `step' every few milliseconds, so it stops almost at
;; once — but "almost" is not "before this line", so wait for it.
(let ((tries 400))
(while (and (> tries 0) (not (eq (flan-state) 'stopped)))
(setq tries (1- tries))
(flan--request (list :op "describe"))
(sleep-for 0.005)))
(test-flan--check "and the program stops there"
(eq (flan-state) 'stopped))
;; A plain `C-c C-c' over the same form replaces the stored declaration
;; with an unmarked one, which is what makes the mark stop sticking — and
;; the overlay has to go with it or the buffer is claiming a breakpoint
;; the daemon no longer has. Allowed while stopped: there is no frame in
;; progress for `step'.
(flan-eval-defun)
(test-flan--check "and an ordinary C-c C-c takes the mark down again"
(null (flan--pause-overlays)))
;; Left running, because the next thing this file does is finish and the
;; daemon's program is killed with it — but a test that ends with the
;; program parked is one nobody can add anything after.
(flan-restart "continue")
(let ((tries 400))
(while (and (> tries 0) (eq (flan-state) 'stopped))
(setq tries (1- tries))
(flan--request (list :op "describe"))
(sleep-for 0.005)))
(test-flan--check "and it resumes when continue is taken"
(not (eq (flan-state) 'stopped))))
(flan-quit)
(ignore-errors (delete-file socket4)))
;; ── C-c C-m: what a macro call expands to ─────────────────────────────
;;
;; test_session.ml drives the expansion itself and is where the language
;; cases live. What this adds is the half that is only true in an editor:
;; which region the command picks, that the expansion arrives as readable
;; source in a buffer, that expanding again in place works, and — the one
;; worth a real daemon — that a macro which never settles comes back as a
;; refusal drawn on the call, at its own line *and its own column*.
;;
;; That last one is what `flan--text-at' exists for. `C-x C-e' sends a
;; raw substring and `flan--text' pads lines only, because a top-level
;; form starts at column 1; a macro call is written well inside a line, and
;; a refusal against it would otherwise be drawn at the start of that line.
(let ((socket5 (concat socket "-macro")))
(ignore-errors (delete-file socket5))
(flan program socket5)
(test-flan--check "a daemon to expand macros against"
(process-live-p flan--connection))
(with-current-buffer (get-file-buffer file)
(goto-char (point-max))
(insert "\n(defn expandable [] i32\n (unless false 1 2)\n (clamp 9 0 3))\n")
;; One step, on a prelude macro. Point on the opening paren, which is
;; where a reader puts it and which `C-x C-e' could not use.
(goto-char (point-max))
(search-backward "(unless false 1 2)")
(flan-macroexpand)
(test-flan--check
"C-c C-m expands the form point is on"
(with-current-buffer flan-macroexpansion-buffer
(string-match-p "(if (not false)" (buffer-string))))
(test-flan--check
"and says which macro ran"
(with-current-buffer flan-macroexpansion-buffer
(string-match-p "macro +unless" (buffer-string))))
(test-flan--check
"and the buffer is Flan source, not a dump"
(with-current-buffer flan-macroexpansion-buffer
(and (derived-mode-p 'flan-mode) buffer-read-only)))
;; The three keys that would send an expansion back as though it were a
;; file refuse by name rather than doing nothing.
(test-flan--check
"C-c C-c in the expansion buffer refuses, and says why"
(with-current-buffer flan-macroexpansion-buffer
(condition-case e (progn (call-interactively
(key-binding (kbd "C-c C-c")))
nil)
(user-error (string-match-p "not source" (error-message-string e))))))
;; All the way, off the same key with a prefix.
(goto-char (point-max))
(search-backward "(clamp 9 0 3)")
(flan-macroexpand t)
(test-flan--check
"C-u C-c C-m expands all the way"
(with-current-buffer flan-macroexpansion-buffer
(and (string-match-p "all the way" (buffer-string))
(string-match-p (regexp-quote "(min 3 (max 0 9))")
(buffer-string)))))
;; A macro that never settles, evaluated into the session and then asked
;; about. One step answers — it makes one call and does not look at what
;; comes back — and all the way is refused at the bound rather than
;; hanging the daemon, which is the failure that would wedge the editor
;; with the program still on screen.
(flan--request
(list :op "eval" :file file
:code "(defmacro spinner [args] `(spinner ~@args))"))
(goto-char (point-max))
(insert "\n(defn spun [] i32\n (spinner 1))\n")
(goto-char (point-max))
(search-backward "(spinner 1)")
(let ((call (point))
(r (flan-macroexpand)))
(test-flan--check
"one step of a macro that does not settle answers"
(and (null (plist-get r :expanded))
(equal (plist-get r :macro) "spinner")))
(flan-clear-errors)
(goto-char call)
(let ((said (condition-case e (progn (flan-macroexpand t) nil)
(user-error (error-message-string e)))))
(test-flan--check
"and all the way is refused rather than hanging"
(and said (string-match-p "did not settle" said)))
;; The whole of `flan--text-at': the refusal's location is the
;; call's own line and column, so the overlay lands on the call and
;; not at the start of the line it is written on.
(let ((ovs (flan--error-overlays)))
(test-flan--check
"and the refusal is drawn on the call, at its own column"
(and (= 1 (length ovs))
(= (overlay-start (car ovs)) call)))))
(flan-clear-errors))
;; Expanding again in place, which is what makes one-step-by-default
;; usable rather than a thing you press once and lose. Two macros into
;; the session, the outer one quasiquoting a call to the inner: that is
;; the shape where one step leaves a macro call standing, and it is the
;; only shape where expanding in place has anything to do.
(flan--request
(list :op "eval" :file file
:code "(defmacro m-inner [args] `(+ ~(at args 0) 1))"))
(flan--request
(list :op "eval" :file file
:code "(defmacro m-outer [args] `(m-inner ~(at args 0)))"))
(goto-char (point-max))
(insert "\n(defn outered [] i32 (m-outer 5))\n")
(goto-char (point-max))
(search-backward "(m-outer 5)")
(flan-macroexpand)
(test-flan--check
"one step leaves the call to the macro it quasiquoted"
(with-current-buffer flan-macroexpansion-buffer
(string-match-p (regexp-quote "(m-inner 5)") (buffer-string))))
(with-current-buffer flan-macroexpansion-buffer
(goto-char (point-min))
(search-forward "(m-inner 5)")
(goto-char (match-beginning 0))
(flan-macroexpand-again)
(test-flan--check
"m in the expansion buffer expands the form at point in place"
(and (string-match-p (regexp-quote "(+ 5 1)") (buffer-string))
(not (string-match-p (regexp-quote "(m-inner 5)")
(buffer-string))))))
;; And the same call taken all the way in one go, which is the half the
;; prefix argument is for: no intermediate at all.
(goto-char (point-max))
(search-backward "(m-outer 5)")
(flan-macroexpand t)
(test-flan--check
"C-u goes straight to the fixpoint"
(with-current-buffer flan-macroexpansion-buffer
(and (string-match-p (regexp-quote "(+ 5 1)") (buffer-string))
(not (string-match-p (regexp-quote "(m-inner 5)")
(buffer-string)))))))
(flan-quit)
(ignore-errors (delete-file socket5)))
(if (zerop test-flan--failures)
(message "flan.el: all tests passed")
(message "\n%d failure(s)" test-flan--failures)
(kill-emacs 1)))
;;; test-flan.el ends here
Reference in New Issue View Git Blame Copy Permalink