Joseph Ferano
0d549a6b6e
The reported bug — the second and later bindings of a let one column too far —
was never one missing rule. `flan-indent-function' checked the head of the
enclosing form, and inside a binding vector the enclosing open is `[' and the
symbol after it is the first binding's name, so it fell through to Emacs's
`lisp-indent-function', which treats the vector as a call and aligns under the
first argument instead of the first binding.
Emacs Lisp is the wrong reference. It has no vectors-as-bindings, no maps and
no bracket variety, so every rule Flan needs has to be added by hand and the
binding vector is simply the first one hit. The indenter is rewritten from
clojure-mode's source instead: `clojure-mode' is neither an ancestor nor a
dependency — flan-mode still needs nothing beyond stock Emacs — it is the file
whose rules were read and written out again.
A bracket aligns under its first element, and that one rule fixes the binding
vector, `defn' parameter lists, `restart-case' and `handler-bind' clause
parameters and both spellings of a struct literal at once. `{:x 1}' and
`{.x 1}' indent identically because nothing here looks at the key, which is
what the colon-to-dot lane needs of it.
Where Flan diverges it is handled on purpose. `defn' is `:defn' rather than a
count because the return type between the parameters and the body is optional.
A clause — `(Name [params] body)' — is recognised by its shape, since its head
is a condition class or a restart name and can never be in a table; clojure-mode
reaches the same clauses by backtracking out to the enclosing form, which buys
generality this language has no other use for. Special arguments indent by one
body rather than Clojure's two, and a call whose head is alone on its line
indents its arguments by a body rather than aligning them under the head,
because that is how the whole corpus is written.
Checked by reindenting every .flan file in the tree: the only lines that move
are sand.flan's reported bug, raylib.flan's hand-wrapped parameter vectors —
which is the fix — and lone-`;' comment continuations, which stock
`lisp-indent-line' has always moved.
test-flan-mode.el is loaded from test-flan-cider.el rather than given a stanza
of its own, because emacs/*.el is already a dependency of that test.
Two failures in test-flan-cider.el that predate this: fixture frames lacked
`:fetched', so folding one open went looking for a daemon, and `layout' was
identified by being the last request when `flan-cnr-show' now makes three.
561 lines
27 KiB
EmacsLisp
561 lines
27 KiB
EmacsLisp
;;; test-flan-cider.el --- The inspector and break buffers, from fixtures -*- lexical-binding: t; -*-
|
|
|
|
;; Run as: emacs -Q --batch -L emacs -l emacs/test-flan-cider.el
|
|
;;
|
|
;; Nothing here needs a daemon or a running program, and that is deliberate
|
|
;; rather than a shortcut. Both buffers are functions from *a reply's data* to
|
|
;; *text with properties on it*, and the interesting failures are all on that
|
|
;; side: a struct the reader mis-parses, a shadowed restart drawn as though it
|
|
;; could be chosen, a section quietly omitted instead of refused. Driving it
|
|
;; from fixtures tests exactly that, and it tests the cases a live program
|
|
;; cannot easily be made to produce — a value past the renderer's depth bound,
|
|
;; two restarts with one name, a frame with locals in it at all.
|
|
;;
|
|
;; The fixtures are not invented. Every rendered string below is the shape
|
|
;; `Session.render' writes, case by case, and the comment on each says which.
|
|
|
|
;;; Code:
|
|
|
|
(require 'flan-inspect)
|
|
(require 'flan-cnr)
|
|
|
|
(defvar test-flan--failures 0)
|
|
(defvar test-flan--ran 0)
|
|
|
|
(defun test-flan--check (name ok)
|
|
(setq test-flan--ran (1+ test-flan--ran))
|
|
(if ok (message " ok %s" name)
|
|
(setq test-flan--failures (1+ test-flan--failures))
|
|
(message " FAIL %s" name)))
|
|
|
|
(defun test-flan--text (thunk)
|
|
"Run THUNK in a scratch buffer and return what it drew."
|
|
(with-temp-buffer
|
|
(funcall thunk)
|
|
(buffer-substring-no-properties (point-min) (point-max))))
|
|
|
|
(defun test-flan--caught (thunk)
|
|
"The message of the error THUNK signals, or nil if it does not."
|
|
(condition-case e (progn (funcall thunk) nil)
|
|
(error (error-message-string e))))
|
|
|
|
|
|
;;; The reader
|
|
|
|
(message "\nreading what the renderer wrote")
|
|
|
|
;; (V {:x 1.5 :y 0}) — Types.Named, lib/session.ml.
|
|
(let ((n (flan-inspect-parse "(V {:x 1.5 :y 0})")))
|
|
(test-flan--check "a struct is a struct" (eq (plist-get n :kind) 'struct))
|
|
(test-flan--check "with its type name" (equal (plist-get n :type) "V"))
|
|
(test-flan--check "and its fields in order"
|
|
(equal (mapcar #'car (plist-get n :children)) '("x" "y")))
|
|
(test-flan--check "carrying their values"
|
|
(equal (plist-get (cdr (assoc "x" (plist-get n :children))) :text)
|
|
"1.5")))
|
|
|
|
;; The whole of NEXT.md's worked example, nested two deep with a string that
|
|
;; has escaped quotes in it and a slice at the end.
|
|
(let* ((src "(Blob {:id 7 :name \"sandy \\\"quoted\\\"\" :pos (V {:x 1.5 :y 0}) :tags [ 0 42 0]})")
|
|
(n (flan-inspect-parse src))
|
|
(kids (plist-get n :children)))
|
|
(test-flan--check "every field of a nested struct"
|
|
(equal (mapcar #'car kids) '("id" "name" "pos" "tags")))
|
|
(test-flan--check "an escaped quote does not end the string early"
|
|
(equal (plist-get (cdr (assoc "name" kids)) :text)
|
|
"\"sandy \"quoted\"\""))
|
|
(test-flan--check "a struct inside a struct"
|
|
(equal (plist-get (cdr (assoc "pos" kids)) :type) "V"))
|
|
(test-flan--check "a slice inside a struct, with its elements"
|
|
(equal (mapcar #'car (plist-get (cdr (assoc "tags" kids)) :children))
|
|
'(0 1 2))))
|
|
|
|
;; [ 0 42 0] — Types.Slice and Types.Array both write this.
|
|
(let ((n (flan-inspect-parse "[ 0 42 0]")))
|
|
(test-flan--check "a sequence is a sequence" (eq (plist-get n :kind) 'seq))
|
|
(test-flan--check "indexed from zero"
|
|
(equal (mapcar #'car (plist-get n :children)) '(0 1 2))))
|
|
|
|
;; [ [ 0 0] [ 1 ...] ...] — span truncation at both levels, which is what
|
|
;; sand's [100 [100 u32]] actually produces.
|
|
(let* ((n (flan-inspect-parse "[ [ 0 0] [ 1 ...] ...]"))
|
|
(kids (plist-get n :children)))
|
|
(test-flan--check "a trailing ... is truncation, not an element"
|
|
(and (= (length kids) 2) (plist-get n :truncated)))
|
|
(test-flan--check "and it is noticed on the inner sequence too"
|
|
(plist-get (cdr (nth 1 kids)) :truncated)))
|
|
|
|
;; The renderer's refusals, each of which becomes a leaf here.
|
|
(test-flan--check "a pointer is a pointer"
|
|
(eq (plist-get (flan-inspect-parse "<ptr>") :kind) 'ptr))
|
|
(test-flan--check "a type the walk had no structure for"
|
|
(eq (plist-get (flan-inspect-parse "<Widget>") :kind) 'opaque))
|
|
(test-flan--check "the depth bound"
|
|
(eq (plist-get (flan-inspect-parse "...") :kind) 'trunc))
|
|
(test-flan--check "an option"
|
|
(eq (plist-get (flan-inspect-parse "(some 3)") :kind) 'option))
|
|
(test-flan--check "an enum member is an atom, not a field"
|
|
(eq (plist-get (flan-inspect-parse ":blue") :kind) 'atom))
|
|
(test-flan--check "and so is a u64 that fills the range"
|
|
(equal (plist-get (flan-inspect-parse "18446744073709551615") :text)
|
|
"18446744073709551615"))
|
|
|
|
;; A struct with a `...' where a field would be: span truncation *inside* a
|
|
;; struct, which is a different position in the grammar from a sequence's.
|
|
(let ((n (flan-inspect-parse "(Wide {:a 1 :b 2 ...})")))
|
|
(test-flan--check "a struct's span bound is truncation, not a field"
|
|
(and (equal (mapcar #'car (plist-get n :children)) '("a" "b"))
|
|
(plist-get n :truncated))))
|
|
|
|
|
|
;;; Where a field is, said in Flan
|
|
|
|
(message "\nthe path is an expression")
|
|
|
|
(test-flan--check "a field is a field accessor"
|
|
(equal (flan-inspect-step-expr "b" '(:field "pos")) "(.pos b)"))
|
|
(test-flan--check "an element is `at'"
|
|
(equal (flan-inspect-step-expr "(.tags b)" '(:index 2))
|
|
"(at (.tags b) 2)"))
|
|
(test-flan--check "and they compose, which is the whole trick"
|
|
(equal (flan-inspect-step-expr
|
|
(flan-inspect-step-expr "b" '(:field "pos")) '(:field "x"))
|
|
"(.x (.pos b))"))
|
|
|
|
|
|
;;; Refusals, by name, with the reason
|
|
|
|
(message "\nwhat cannot be entered says so")
|
|
|
|
(dolist (case '(("<ptr>" "pointer") ("..." "depth bound") ("7" "atom")
|
|
("(some 3)" "accessor form") ("<Widget>" "no structure")))
|
|
(let ((why (flan-inspect-refusal (flan-inspect-parse (car case)))))
|
|
(test-flan--check (format "%s refuses, naming %s" (car case) (cadr case))
|
|
(and why (string-match-p (regexp-quote (cadr case)) why)))))
|
|
|
|
(test-flan--check "a struct with fields does not refuse"
|
|
(null (flan-inspect-refusal (flan-inspect-parse "(V {:x 1 :y 2})"))))
|
|
|
|
|
|
;;; The inspector buffer
|
|
|
|
(message "\nthe inspector buffer")
|
|
|
|
(defun test-flan--inspect (expr rendered)
|
|
"Draw EXPR's RENDERED value in a temp buffer and return it, live."
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_) (list :status "ok" :value rendered)))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
|
(save-window-excursion (flan-inspect--show expr nil))))
|
|
|
|
(let* ((buf (test-flan--inspect
|
|
"b" "(Blob {:id 7 :name \"sandy\" :pos (V {:x 1.5 :y 0})})"))
|
|
(text (with-current-buffer buf (buffer-string))))
|
|
(test-flan--check "the expression is at the top" (string-match-p "\\`b\n" text))
|
|
(test-flan--check "and the type under it" (string-match-p "a Blob" text))
|
|
(test-flan--check "the fields are listed" (string-match-p ":id.*7" text))
|
|
(test-flan--check "a nested struct is summarised, not expanded"
|
|
(string-match-p ":pos +(V … 2 fields)" text))
|
|
(test-flan--check "and the keys are shown" (string-match-p "RET inspect" text))
|
|
;; Every field line carries the step that reaches it.
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(test-flan--check "TAB lands on the first field"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "id")))
|
|
(flan-inspect-next)
|
|
(flan-inspect-next)
|
|
(test-flan--check "and walks to the third"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "pos")))
|
|
;; Backwards is the same list walked the other way. It is tested because
|
|
;; an asymmetry here is the kind of thing nobody reports and everybody
|
|
;; notices — and because point lands mid-line after a search, where a
|
|
;; property-change walk and a field walk disagree.
|
|
(flan-inspect-previous)
|
|
(test-flan--check "p comes back to the second"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "name")))
|
|
;; From the middle of a line, `p' goes to the start of the field point is
|
|
;; *in*, which is CIDER's behaviour and the reason both commands go
|
|
;; through one list of field starts: walking property changes from
|
|
;; mid-line finds the end of the current field instead, and forward and
|
|
;; backward then disagree about where a field begins.
|
|
(end-of-line)
|
|
(flan-inspect-previous)
|
|
(test-flan--check "from mid-line, p reaches this field's start"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "name")))
|
|
(flan-inspect-previous)
|
|
(test-flan--check "and then the one before it"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "id")))
|
|
(flan-inspect-previous)
|
|
(test-flan--check "p wraps to the last, as n wraps to the first"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "pos")))
|
|
(flan-inspect-next)
|
|
(test-flan--check "and n wraps round from it"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "id")))))
|
|
|
|
;; Going in sends a *different expression*, which is the entire adaptation.
|
|
(let ((asked nil))
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form)
|
|
(push (plist-get form :code) asked)
|
|
(list :status "ok"
|
|
:value (if (equal (plist-get form :code) "(.pos b)")
|
|
"(V {:x 1.5 :y 0})"
|
|
"(Blob {:id 7 :pos (V {:x 1.5 :y 0})})"))))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
|
(save-window-excursion
|
|
(flan-inspect--show "b" nil)
|
|
(with-current-buffer " *test-inspect*"
|
|
(goto-char (point-min))
|
|
(flan-inspect-next) (flan-inspect-next) ; :pos
|
|
(flan-inspect-into)
|
|
(test-flan--check "going in asks for the accessor expression"
|
|
(equal (car asked) "(.pos b)"))
|
|
(test-flan--check "and the buffer is now showing that"
|
|
(string-match-p "\\`(\\.pos b)\n" (buffer-string)))
|
|
(test-flan--check "with the stack behind it"
|
|
(string-match-p "via b > here" (buffer-string)))
|
|
(flan-inspect-pop)
|
|
(test-flan--check "coming back asks for the one we came from"
|
|
(equal (car asked) "b"))
|
|
(test-flan--check "and there is no stack left"
|
|
(not (string-match-p "via" (buffer-string))))
|
|
(test-flan--check "popping at the root refuses"
|
|
(string-match-p
|
|
"nothing behind it"
|
|
(or (test-flan--caught #'flan-inspect-pop) "")))))))
|
|
|
|
;; RET on something that cannot be entered refuses there, rather than sending
|
|
;; an expression the program would reject.
|
|
(let* ((buf (test-flan--inspect "p" "(Node {:next <ptr> :n 1})")))
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(test-flan--check "RET on a pointer field refuses, naming it"
|
|
(string-match-p "pointer"
|
|
(or (test-flan--caught #'flan-inspect-into) "")))))
|
|
|
|
;; An atom root has nothing to go into, and the buffer says so rather than
|
|
;; drawing an empty field list.
|
|
(let ((text (with-current-buffer (test-flan--inspect "(.x p)" "1.5") (buffer-string))))
|
|
(test-flan--check "an atom root explains itself"
|
|
(string-match-p "Nothing to go into:.*atom" text)))
|
|
|
|
;; The span bound is drawn, because a field list that silently stops is a lie
|
|
;; about the value.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--inspect "w" "(Wide {:a 1 :b 2 ...})") (buffer-string))))
|
|
(test-flan--check "span truncation is drawn, not dropped"
|
|
(string-match-p "span bound of 8" text)))
|
|
|
|
|
|
|
|
|
|
;;; Restarts: which of them can be taken
|
|
|
|
(message "\nrestarts, and §4's shadowing")
|
|
|
|
(let ((rows (flan-cnr-annotate-restarts '("retry" "use-placeholder" "retry" "skip"))))
|
|
(test-flan--check "numbered from zero, innermost first"
|
|
(equal (mapcar (lambda (r) (nth 0 r)) rows) '(0 1 2 3)))
|
|
(test-flan--check "the first of a name owns it"
|
|
(null (nth 2 (nth 0 rows))))
|
|
(test-flan--check "a repeat is shadowed by it"
|
|
(equal (nth 2 (nth 2 rows)) 0))
|
|
(test-flan--check "and a different name is not"
|
|
(null (nth 2 (nth 3 rows)))))
|
|
|
|
(test-flan--check "no restarts is a list of no rows"
|
|
(null (flan-cnr-annotate-restarts nil)))
|
|
|
|
|
|
;;; The break buffer
|
|
|
|
(message "\nthe break buffer")
|
|
|
|
(defun test-flan--cnr (state)
|
|
"Draw STATE and return the buffer."
|
|
(let ((buf (get-buffer-create " *test-cnr*")))
|
|
(with-current-buffer buf
|
|
(let ((inhibit-read-only t)) (erase-buffer))
|
|
(flan-cnr-mode)
|
|
(setq flan-cnr--open nil)
|
|
(flan-cnr--render state))
|
|
buf))
|
|
|
|
;; What the daemon can answer today, and nothing more: a class name and a list
|
|
;; of names.
|
|
(let* ((buf (test-flan--cnr
|
|
(list :condition "Missing"
|
|
:restarts '("retry" "use-placeholder" "retry"))))
|
|
(text (with-current-buffer buf (buffer-string))))
|
|
;; SBCL's order, which is the claim this buffer is making.
|
|
(test-flan--check "the condition is first"
|
|
(string-match-p "\\`Missing" text))
|
|
(test-flan--check "the restarts are before the stack"
|
|
(< (string-match "Restarts" text) (string-match "Stack" text)))
|
|
(test-flan--check "restarts are numbered"
|
|
(string-match-p " 0: \\[retry\\]" text))
|
|
(test-flan--check "a shadowed one has no bracket, as SBCL's has none"
|
|
(string-match-p " 2: retry " text))
|
|
(test-flan--check "and says why, and what it would take"
|
|
(string-match-p "shadowed by 0.*restart-at" text))
|
|
(test-flan--check "abort is the last entry on the same list"
|
|
(string-match-p " 3: \\[abort\\]" text))
|
|
;; The rule: nothing implemented is refused by name, with the reason. These
|
|
;; three sections exist and are empty, and each says what would fill it.
|
|
;; The shape of a condition and the values in it are two different
|
|
;; refusals, and with nothing at all the outer one is what shows.
|
|
(test-flan--check "the condition's fields are refused, not omitted"
|
|
(string-match-p "Condition fields:\n not available.*Tast.structs" text))
|
|
;; The stack is no longer refused for want of a mechanism — the shadow stack
|
|
;; landed and the daemon answers `backtrace'. What this fixture has is no
|
|
;; stack *passed in*, which is the running-program case, so the reason it
|
|
;; names is that one.
|
|
(test-flan--check "the stack says the program is running, not that it is unbuilt"
|
|
(string-match-p "Stack.*\n not available.*running"
|
|
(substring text (string-match "--- Stack" text))))
|
|
(test-flan--check "and the keys are shown" (string-match-p "TAB fold a frame" text)))
|
|
|
|
;; A stopped program with nothing on offer between the error and the top. It
|
|
;; is a real state — spec-conditions §2's `error' with no `restart-case' above
|
|
;; it — and it must not look like a bug in the buffer.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr (list :condition "Missing" :restarts nil))
|
|
(buffer-string))))
|
|
(test-flan--check "no restarts is said, not drawn blank"
|
|
(string-match-p "none are active" text))
|
|
(test-flan--check "and abort is still offered"
|
|
(string-match-p " 0: \\[abort\\]" text)))
|
|
|
|
;; Taking one sends `restart' with the name.
|
|
(let ((sent nil))
|
|
(let ((flan-cnr-request-function
|
|
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry" "skip")))
|
|
(goto-char (point-min))
|
|
(search-forward " 1: ")
|
|
(save-window-excursion (flan-cnr-take))
|
|
(test-flan--check "RET on a restart sends its name"
|
|
(equal sent '(:op "restart" :name "skip"))))))
|
|
|
|
;; And a shadowed one is refused here rather than sent, which is the bug in
|
|
;; today's `completing-read': it would send "retry" and the *inner* frame would
|
|
;; take it, silently.
|
|
(let ((sent nil))
|
|
(let ((flan-cnr-request-function (lambda (form) (setq sent form) '(:status "ok"))))
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry" "a" "retry")))
|
|
(goto-char (point-min))
|
|
(search-forward " 2: ")
|
|
(let ((err (test-flan--caught #'flan-cnr-take)))
|
|
(test-flan--check "a shadowed restart refuses"
|
|
(and err (string-match-p "shadowed by 0" err)))
|
|
(test-flan--check "and nothing was sent" (null sent))))))
|
|
|
|
;; A digit takes one, as it does in SBCL.
|
|
(let ((sent nil))
|
|
(let ((flan-cnr-request-function
|
|
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry" "skip")))
|
|
(goto-char (point-max))
|
|
(let ((last-command-event ?0))
|
|
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
|
|
(test-flan--check "0 takes the innermost"
|
|
(equal sent '(:op "restart" :name "retry")))
|
|
(let ((last-command-event ?2))
|
|
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
|
|
(test-flan--check "and the number past the last is abort"
|
|
(equal sent '(:op "abort"))))))
|
|
|
|
;; The stack and its locals. The fixture is the shape `backtrace' and `locals'
|
|
;; answer with, and both frames carry `:fetched t' because their locals are
|
|
;; already here: without it `flan-cnr-toggle-frame' goes and asks the daemon
|
|
;; for them, and there is no daemon behind these tests on purpose.
|
|
(let* ((state (list :condition "Missing"
|
|
:restarts '("retry")
|
|
:stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
|
|
:fetched t
|
|
:locals '(("i" "i32" "7")
|
|
("b" "Blob" "(Blob {:id 7})")))
|
|
(list :fn "sim/step" :loc "sand.flan:60:1"
|
|
:fetched t :locals nil))))
|
|
(buf (test-flan--cnr state))
|
|
(text (with-current-buffer buf (buffer-string))))
|
|
(test-flan--check "frames are numbered, innermost first"
|
|
(string-match-p " 0: > sim/settle" text))
|
|
(test-flan--check "with where they are" (string-match-p "sand.flan:42:3" text))
|
|
(test-flan--check "locals are collapsed to begin with"
|
|
(not (string-match-p "i32 i = 7" text)))
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(search-forward " 0: > sim/settle")
|
|
(flan-cnr-toggle-frame)
|
|
(test-flan--check "TAB on a frame opens its locals"
|
|
(string-match-p "i32 i = 7" (buffer-string)))
|
|
(test-flan--check "and the marker turns"
|
|
(string-match-p " 0: v sim/settle" (buffer-string)))
|
|
;; A frame whose locals nobody could read says so, in the same place the
|
|
;; locals would have been.
|
|
(goto-char (point-min))
|
|
(search-forward " 1: > sim/step")
|
|
(flan-cnr-toggle-frame)
|
|
;; DWARF stopped being the reason when the shadow stack landed: a frame
|
|
;; with nothing nameable is one whose slots the compiler invented, or whose
|
|
;; bindings had not run.
|
|
(test-flan--check "a frame with no locals refuses, with a reason"
|
|
(string-match-p "not available.*no named locals"
|
|
(buffer-string)))
|
|
(goto-char (point-min))
|
|
(search-forward " 0: v sim/settle")
|
|
(flan-cnr-toggle-frame)
|
|
(test-flan--check "and TAB again closes it"
|
|
(not (string-match-p "i32 i = 7" (buffer-string))))))
|
|
|
|
;; The two buffers meet: `i' on a local opens the inspector on its name, which
|
|
;; is an expression the program can be handed.
|
|
(let ((asked nil))
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form) (push (plist-get form :code) asked)
|
|
(list :status "ok" :value "(Blob {:id 7})")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry")
|
|
:stack (list (list :fn "f" :fetched t
|
|
:locals '(("b" "Blob" "…"))))))
|
|
(goto-char (point-min))
|
|
(search-forward " 0: > f")
|
|
(flan-cnr-toggle-frame)
|
|
(goto-char (point-min))
|
|
(search-forward "Blob b")
|
|
(save-window-excursion (flan-cnr-inspect))
|
|
(test-flan--check "`i' on a local inspects it by name"
|
|
(equal (car asked) "b")))))
|
|
|
|
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
|
;; empty buffer.
|
|
;; The layout without the values: what a `layout' op alone would buy. The
|
|
;; names and the types come out of Tast.structs, which the daemon holds
|
|
;; whether or not a program is running; only the values need the pointer the
|
|
;; break loop was handed. Drawing the two apart is strictly more than saying
|
|
;; nothing, and it is what tells you whether the field you were about to
|
|
;; blame is even a field of this condition.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr (list :condition "Missing" :restarts '("retry")
|
|
:fields '(("path" "string" nil)
|
|
("tried" "i32" "3"))))
|
|
(buffer-string))))
|
|
(test-flan--check "a field is named and typed even with no value"
|
|
(string-match-p ":path *string *value not available" text))
|
|
(test-flan--check "and the missing value names the verb it needs"
|
|
(string-match-p "value not available.*agent verb: `condition'" text))
|
|
(test-flan--check "a value that is there is simply shown"
|
|
(string-match-p ":tried *i32 *3" text)))
|
|
|
|
;; Backwards through the buffer, for the same reason as in the inspector.
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry" "skip")))
|
|
(goto-char (point-min))
|
|
(search-forward "[abort]")
|
|
(beginning-of-line)
|
|
(flan-cnr-previous)
|
|
(test-flan--check "p from abort lands on the last restart"
|
|
(equal (get-text-property (point) 'flan-cnr-index) 1))
|
|
(flan-cnr-next)
|
|
(test-flan--check "and n goes back to abort"
|
|
(get-text-property (point) 'flan-cnr-abort)))
|
|
|
|
|
|
;; The `layout' op, from this side: the condition's own name goes out as
|
|
;; `:type' and comes back as fields with no values. Two requests are made for
|
|
;; one `C-c C-b' — `break', `layout', then `backtrace' — so the stub records
|
|
;; all three. The assertions below look the `layout' request up by op rather
|
|
;; than by position: this list grew once already when `backtrace' landed, and a
|
|
;; positional assertion breaks every time the buffer learns to ask something
|
|
;; new, which is not what it is testing.
|
|
(let ((asked nil))
|
|
(let ((flan-cnr-request-function
|
|
(lambda (form)
|
|
(push form asked)
|
|
(pcase (plist-get form :op)
|
|
("break" '(:status "ok" :stopped t :condition "sim/Missing"
|
|
:restarts ("retry")))
|
|
("layout" '(:status "ok" :type "sim/Missing"
|
|
:fields (("path" "string") ("tried" "i32"))))))))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
|
|
(buffer-string))))
|
|
(test-flan--check "the condition's name is what `layout' is asked for"
|
|
(equal (plist-get (car (last asked)) :op) "break"))
|
|
;; By op rather than by position: `flan-cnr-show' asks three things now —
|
|
;; `break', `layout', `backtrace' — and which of them is last is not what
|
|
;; this is testing.
|
|
(test-flan--check "and it is sent back verbatim, qualified as it came"
|
|
(equal (plist-get
|
|
(seq-find (lambda (f)
|
|
(equal (plist-get f :op) "layout"))
|
|
asked)
|
|
:type)
|
|
"sim/Missing"))
|
|
(test-flan--check "the fields are drawn, named and typed"
|
|
(string-match-p ":path *string" text))
|
|
;; Shape and contents are two different questions, and only the first is
|
|
;; answerable without the pointer the break loop discards.
|
|
(test-flan--check "and every value still says why it is missing"
|
|
(string-match-p ":tried *i32 *value not available" text)))))
|
|
|
|
;; A layout the daemon refuses — a bare name it will not guess between two
|
|
;; packages, or a type it cannot place — leaves the section drawing its reason
|
|
;; rather than turning `C-c C-b' into an error. The restarts are the decision
|
|
;; in front of you and they are still there.
|
|
(let ((flan-cnr-request-function
|
|
(lambda (form)
|
|
(pcase (plist-get form :op)
|
|
("break" '(:status "ok" :stopped t :condition "Missing"
|
|
:restarts ("retry")))
|
|
("layout" '(:status "error" :message "Missing is not a qualified name"
|
|
:candidates ("a/Missing" "b/Missing")))))))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
|
|
(buffer-string))))
|
|
(test-flan--check "a refused layout is a section that says so"
|
|
(string-match-p "not available.*needs a \\*qualified\\* name" text))
|
|
(test-flan--check "and the restarts are drawn anyway"
|
|
(string-match-p "\\[retry\\]" text))))
|
|
|
|
(let ((flan-cnr-request-function
|
|
(lambda (_) '(:status "ok" :restarts nil :stopped nil))))
|
|
(test-flan--check "a running program is refused, by name"
|
|
(string-match-p "no restart stack"
|
|
(or (test-flan--caught #'flan-cnr-show) ""))))
|
|
|
|
(let ((flan-cnr-request-function
|
|
(lambda (_) '(:status "error" :message "the program exited"))))
|
|
(test-flan--check "and the daemon's own refusal is passed through"
|
|
(string-match-p "the program exited"
|
|
(or (test-flan--caught #'flan-cnr-show) ""))))
|
|
|
|
|
|
;; `flan-mode' itself — indentation, which is a function from text to text and
|
|
;; so belongs with the other fixture-driven checks rather than with anything
|
|
;; that needs a daemon. Loaded rather than run separately because
|
|
;; `emacs/*.el' is already a dependency of test/dune's stanza, so a file here
|
|
;; needs no build change to be run.
|
|
(load (expand-file-name "test-flan-mode.el"
|
|
(file-name-directory load-file-name))
|
|
nil t)
|
|
|
|
(message "\n%d checks, %d failures" test-flan--ran test-flan--failures)
|
|
(kill-emacs (if (> test-flan--failures 0) 1 0))
|
|
|
|
;;; test-flan-cider.el ends here
|