Joseph Ferano
635d12782d
A global is program state a frame happened to touch, not part of it, so nesting it under one implies an ownership that is not there and repeats the name once per frame that reads it. One section instead, holding the union of the globals every frame on the stack references — the compiler does the choosing, since Reach.expr_refs already answers a body's reference set, and listing every global a program has would bury the one that matters under the prelude's PRNG state. Each entry says which frames touch it, by the index the stack section already numbers them with, which recovers what per-frame nesting would have told you at no cost in duplication. Ordered by the innermost frame that touches it: a deep stack makes the union large and proximity to the error is what puts the likely culprit on top. Simpler than locals, because a global is reached by name rather than by address. Emit.redefinition writes a global the host has as external, so the thunk binds to the program's own storage and nothing is asked of the stopped thread — no dev-slot round trip and no not-yet-bound case to refuse. A frame that cannot be attributed contributes nothing and is named in :skipped; the union being incomplete and the union being complete are different answers. The hole in that is stated rather than papered over: slot_fingerprint hashes a body's slots, which is the right cut for locals and not for this, so a body that names different globals while binding the same locals is not caught. The test drives the case that is. MANUAL.md also loses a stale paragraph claiming the fingerprint check never fires with a failing test pinned to it. It fires, and test_dev covers it.
788 lines
39 KiB
EmacsLisp
788 lines
39 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)
|
|
;; For `flan-dev--auto-break', which is a decision about globals and windows
|
|
;; and needs neither a daemon nor a socket to be asked.
|
|
(require 'flan-dev)
|
|
|
|
(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})"))))
|
|
|
|
(test-flan--check "and a pointer says the address is not there either"
|
|
(string-match-p "does not write the address"
|
|
(flan-inspect-refusal
|
|
(flan-inspect-parse "<ptr>"))))
|
|
|
|
|
|
;;; What a number reads as in the other two bases
|
|
|
|
;; Arithmetic on text the renderer already wrote: nothing is asked of the
|
|
;; program, which is why these need no daemon and no fixture beyond the string.
|
|
|
|
(message "\na number in the other bases")
|
|
|
|
(dolist (case '(("255" "0xFF" "0b1111_1111")
|
|
("0" "0x0" "0b0")
|
|
("7" "0x7" "0b0111")
|
|
;; sand.flan's world-edge colour, which is the case this is for:
|
|
;; written 0x303030FF in the source and decimal everywhere else.
|
|
("808464639" "0x303030FF" "0b0011_0000_0011_0000_0011_0000_1111_1111")))
|
|
(let ((detail (flan-inspect--detail (flan-inspect-parse (nth 0 case)))))
|
|
(test-flan--check (format "%s is %s" (nth 0 case) (nth 1 case))
|
|
(and detail (string-match-p (regexp-quote (nth 1 case)) detail)))
|
|
(test-flan--check (format "%s is %s" (nth 0 case) (nth 2 case))
|
|
(and detail (string-match-p (regexp-quote (nth 2 case)) detail)))))
|
|
|
|
;; A negative is the 64-bit two's complement it is in memory, and says so: the
|
|
;; rendered value carries no width, and every Flan integer comes back through
|
|
;; i64, so 64 is the one that can be stated honestly.
|
|
(let ((detail (flan-inspect--detail (flan-inspect-parse "-1"))))
|
|
(test-flan--check "a negative is two's complement, at a stated width"
|
|
(and detail
|
|
(string-match-p "0xFFFFFFFFFFFFFFFF" detail)
|
|
(string-match-p "64-bit" detail))))
|
|
|
|
;; The whole u64 range, which is past a fixnum and relies on bignums.
|
|
(test-flan--check "a u64 at the top of its range"
|
|
(string-match-p
|
|
"0xFFFFFFFFFFFFFFFF"
|
|
(or (flan-inspect--detail
|
|
(flan-inspect-parse "18446744073709551615")) "")))
|
|
|
|
;; Not everything that looks numeric is one. A float's bits are an IEEE layout
|
|
;; and the rendered text does not carry the width to reinterpret them, so it is
|
|
;; left alone rather than answered wrongly.
|
|
(dolist (text '("1.5" "-0.25" "true" ":green" "none" "..." "<ptr>" "\"7\""))
|
|
(test-flan--check (format "%s has no other base" text)
|
|
(null (flan-inspect--detail (flan-inspect-parse text)))))
|
|
|
|
;; And it reaches the buffer, in both places it is drawn: the header of a value
|
|
;; opened on its own, and the field list where a leaf can only ever be seen.
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_) '(:status "ok" :value "255")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-inspect "flags"))
|
|
(buffer-string))))
|
|
(test-flan--check "a number opened on its own shows its bases"
|
|
(string-match-p "0xFF 0b1111_1111" text))))
|
|
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_) '(:status "ok" :value "(Mask {.bits 255 .name \"all\"})")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-inspect "m"))
|
|
(buffer-string))))
|
|
(test-flan--check "and a numeric field shows them in the field list"
|
|
(string-match-p "\\.bits +255 +0xFF 0b1111_1111" text))
|
|
(test-flan--check "while a string field is left alone"
|
|
(string-match-p "\\.name +\"all\"\n" text))))
|
|
|
|
|
|
;;; 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))))
|
|
|
|
;; The globals section. One section rather than a fold under each frame, and
|
|
;; the fixtures below are what makes that visible: `grid' is touched by two
|
|
;; frames and appears once.
|
|
(let* ((state (list :condition "Boom"
|
|
:restarts '("retry")
|
|
:stack (list (list :fn "sim/inner" :loc "g.flan:12:1")
|
|
(list :fn "main" :loc "g.flan:30:1"))
|
|
;; Ordered as the daemon orders it: by the innermost frame
|
|
;; that touches each one.
|
|
:globals '(("grid" "[4 i32]" "[ 7 5 0 0]" (0 1))
|
|
("pressure" "i64" "12" (0))
|
|
("label" "string" "\"running\"" (1)))))
|
|
(buf (test-flan--cnr state))
|
|
(text (with-current-buffer buf (buffer-string))))
|
|
(test-flan--check "a global is named, typed and valued"
|
|
(string-match-p "pressure +i64 = 12" text))
|
|
(test-flan--check "and it is one section, not one per frame"
|
|
(= 1 (seq-count (lambda (l) (string-match-p "grid" l))
|
|
(split-string text "\n"))))
|
|
;; The annotation is what recovers the half per-frame nesting would have
|
|
;; told you, and it costs no duplication to say it.
|
|
(test-flan--check "a global two frames touch says both"
|
|
(string-match-p "frames 0, 1" text))
|
|
(test-flan--check "and one only the innermost touches says one"
|
|
(string-match-p "frame 0\n" text))
|
|
(test-flan--check "the innermost frame's globals come first"
|
|
(< (string-match "pressure" text) (string-match "label" text)))
|
|
;; `i' reaches a global the same way it reaches a local: a global's name is
|
|
;; an expression the program can be handed, which is the whole trick the
|
|
;; inspector is built on.
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(test-flan--check "and a global line is inspectable"
|
|
(progn (search-forward "pressure")
|
|
(equal (get-text-property (point) 'flan-cnr-inspect)
|
|
"pressure")))))
|
|
|
|
;; Empty is a claim, not a gap: the section is the union of what the stack
|
|
;; reaches, so nothing in it means the state is all in the locals.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr (list :condition "Boom" :restarts '("retry")
|
|
:stack (list (list :fn "f"))))
|
|
(buffer-string))))
|
|
(test-flan--check "an empty globals section says what empty means"
|
|
(string-match-p "not available.*union of what the frames reach"
|
|
text)))
|
|
|
|
;; A frame the daemon could not attribute makes the union smaller than the real
|
|
;; one, and a list that is short without saying so is the failure this whole
|
|
;; buffer is built to avoid.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr
|
|
(list :condition "Boom" :restarts '("retry")
|
|
:stack (list (list :fn "f"))
|
|
:globals '(("label" "string" "\"x\"" (1)))
|
|
:globals-refused '(("weird" "no printer for (Map i64 i64)"))
|
|
:globals-skipped
|
|
'(("0: sim/inner" "this frame's body was redefined since it was entered"))))
|
|
(buffer-string))))
|
|
(test-flan--check "a global with no printer is refused by name"
|
|
(string-match-p "weird: no printer" text))
|
|
(test-flan--check "an unattributable frame says the union is incomplete"
|
|
(string-match-p "union is incomplete" text))
|
|
(test-flan--check "and names the frame it lost"
|
|
(string-match-p "0: sim/inner" text)))
|
|
|
|
;; The fetch is a function from a reply to data, like the other two, so it is
|
|
;; drivable with no socket.
|
|
(let ((flan-cnr-request-function
|
|
(lambda (_) '(:status "ok"
|
|
:globals (("g" "i64" "1" (0)))
|
|
:refused (("h" "no printer"))
|
|
:skipped (("1: m" "redefined"))))))
|
|
(let ((got (flan-cnr-globals)))
|
|
(test-flan--check "globals come back as entries, refusals and skipped frames"
|
|
(equal got '((("g" "i64" "1" (0)))
|
|
(("h" "no printer"))
|
|
(("1: m" "redefined")))))))
|
|
|
|
(let ((flan-cnr-request-function (lambda (_) '(:status "error" :message "running"))))
|
|
(test-flan--check "and a refusal is nil, not an error"
|
|
(null (flan-cnr-globals))))
|
|
|
|
(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) ""))))
|
|
|
|
|
|
;;; Opening the break buffer by itself
|
|
|
|
;; `flan-dev--auto-break' is a decision — given the state the client is in,
|
|
;; does the break buffer appear — so it is asked here with the state bound
|
|
;; rather than by stopping a real program. Every guard in it exists because
|
|
;; the answer is no in some state a person is actually in.
|
|
|
|
(message "\nthe break buffer opening itself")
|
|
|
|
(defun test-flan--auto-break (&rest bindings)
|
|
"Non-nil if `flan-dev--auto-break' would show the buffer.
|
|
BINDINGS is a plist of extra state; the defaults are a live connection and a
|
|
stopped program, which is the case where it should fire."
|
|
(let ((shown nil))
|
|
(cl-letf (((symbol-function 'flan-cnr-show) (lambda () (setq shown t) nil))
|
|
;; A process object that is not live, and `process-live-p' of a
|
|
;; non-process is nil — so the default has to be overridden by
|
|
;; the caller, which is what `:live' does.
|
|
((symbol-function 'process-live-p)
|
|
(lambda (_) (if (plist-member bindings :live)
|
|
(plist-get bindings :live) t))))
|
|
(let ((flan-dev--stopped
|
|
(if (plist-member bindings :stopped)
|
|
(plist-get bindings :stopped) "Missing"))
|
|
(flan-dev-break-on-stop
|
|
(if (plist-member bindings :setting)
|
|
(plist-get bindings :setting) 'display))
|
|
(flan-dev--busy (plist-get bindings :busy))
|
|
(executing-kbd-macro (plist-get bindings :macro))
|
|
(flan-dev--connection 'stub))
|
|
(flan-dev--auto-break)))
|
|
shown))
|
|
|
|
(test-flan--check "a stopped program opens it"
|
|
(test-flan--auto-break))
|
|
(test-flan--check "a running one does not"
|
|
(not (test-flan--auto-break :stopped nil)))
|
|
(test-flan--check "nor does a connection that has gone"
|
|
(not (test-flan--auto-break :live nil)))
|
|
;; The reason it is deferred at all: `flan-dev--absorb' notices the stop in the
|
|
;; middle of reading a reply, and three more requests down the same socket
|
|
;; would interleave two conversations.
|
|
(test-flan--check "nor while a request is still in flight"
|
|
(not (test-flan--auto-break :busy t)))
|
|
;; A prompt is modal and someone is in the middle of it.
|
|
(test-flan--check "nor under an active minibuffer"
|
|
(let ((probe (lambda (&rest _) t)))
|
|
(advice-add 'active-minibuffer-window :override probe)
|
|
(unwind-protect (not (test-flan--auto-break))
|
|
(advice-remove 'active-minibuffer-window probe))))
|
|
;; A macro must do the same thing every time it is run, and whether the program
|
|
;; happened to stop during it is not something a macro can depend on.
|
|
(test-flan--check "nor inside a keyboard macro"
|
|
(not (test-flan--auto-break :macro t)))
|
|
(test-flan--check "and not at all when it is turned off"
|
|
(not (test-flan--auto-break :setting nil)))
|
|
|
|
;; `(pause)' is a stop and not a failure, and it is the one thing about it that
|
|
;; the buffer gets to say differently. Everything underneath is identical.
|
|
(let ((text (test-flan--text
|
|
(lambda () (flan-cnr--insert-condition
|
|
(list :condition flan-cnr-breakpoint))))))
|
|
(test-flan--check "a breakpoint is called a breakpoint"
|
|
(string-match-p "a breakpoint; stopped where (pause)" text))
|
|
(test-flan--check "and is not called unhandled"
|
|
(not (string-match-p "unhandled" text))))
|
|
|
|
(let ((text (test-flan--text
|
|
(lambda () (flan-cnr--insert-condition '(:condition "Missing"))))))
|
|
(test-flan--check "while an error still is"
|
|
(string-match-p "unhandled" text)))
|
|
|
|
|
|
;; `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
|