546 lines
26 KiB
EmacsLisp
546 lines
26 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. Nothing produces this data today; the fixture is
|
|
;; the shape a `backtrace' verb would have to answer with, and building the
|
|
;; buffer against it is how it is ready when one exists.
|
|
(let* ((state (list :condition "Missing"
|
|
:restarts '("retry")
|
|
:stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
|
|
:locals '(("i" "i32" "7")
|
|
("b" "Blob" "(Blob {:id 7})")))
|
|
(list :fn "sim/step" :loc "sand.flan:60:1"
|
|
: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" :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"))
|
|
(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) ""))))
|
|
|
|
|
|
(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
|